[Shootout-list] fannkuch in Scheme
Isaac Gouy
igouy2@yahoo.com
Tue, 21 Dec 2004 08:59:07 -0800 (PST)
> 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