[Shootout-list] fannkuch in Scheme

[Dima Dorfman]

--L6iaP+gRLNZHKoI4
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline

Attached is a fannkuch implementation in Scheme. It uses the same
successor algorithm as Simon Geard's f90 implementation posted on
Sunday, but I actually wrote this last week (it's a well-known
algorithm).

Dima.

--L6iaP+gRLNZHKoI4
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="fannkuch.scm"

;; fannkuch benchmark for The Computer Language Shootout
;; Written by Dima Dorfman, 2004
;; Compile with bigloo: bigloo -Obench -unsafe -o fannkuch_bigloo fannkuch.scm

(module nsieve (main main))

(define (1+ i) (+ i 1))
(define (1- i) (- i 1))

(define (vector-swap! v i j)
  (let ((t (vector-ref v i)))
    (vector-set! v i (vector-ref v j))
    (vector-set! v j t)))

(define (vector-reverse-slice! v i j)
  (do ((i i (1+ i))
       (j j (1- j)))
      ((<= (- j i) 1))
    (vector-swap! v i (1- j))))

(define (count-flips pi)
  (do ((rho (vector-copy pi))
       (i 0 (1+ i)))
      ((= (vector-ref rho 0) 1) i)
    (vector-reverse-slice! rho 0 (vector-ref rho 0))))

(define (successor! pi)
  (let ((i (let loop ((i (- (vector-length pi) 2)))
	     (cond ((< i 0) #f)
		   ((> (vector-ref pi (1+ i)) (vector-ref pi i)) i)
		   (else (loop (1- i)))))))
    (if (not i) #f
	(let* ((ith (vector-ref pi i))
	       (j (do ((j (1- (vector-length pi)) (1- j)))
		      ((> (vector-ref pi j) ith) j))))
	  (vector-swap! pi i j)
	  (vector-reverse-slice! pi (1+ i) (vector-length pi))
	  #t))))

(define (fannkuch n)
  (let ((pi (do ((pi (make-vector n))
		 (i 0 (1+ i)))
		((= i (vector-length pi)) pi)
	      (vector-set! pi i (1+ i)))))
    (let loop ((flips 0))
      (let ((flips (max (count-flips pi) flips)))
	(if (successor! pi)
	    (loop flips)
	    flips)))))

(define (main args)
  (if (< (length args) 2)
      (begin (display "An argument is required") (newline) 2)
      (let ((n (string->number (cadr args))))
	(if (not n)
	    (begin (display "An integer is required") (newline) 2)
	    (let ((f (fannkuch n)))
	      (begin
		(display "fannkuch(")
		(display n)
		(display ") = ")
		(display f)
		(newline))
	      0)))))

--L6iaP+gRLNZHKoI4--