[Shootout-list] fannkuch in Scheme

[Isaac Gouy]

> 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).

I haven't looked at Simon's implementation - does it follow the steps
given in the problem description?

 
> Dima.
> > ;; 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)))))
> 



		
__________________________________ 
Do you Yahoo!? 
The all-new My Yahoo! - What will yours do?
http://my.yahoo.com