63 lines
1.9 KiB
Scheme
63 lines
1.9 KiB
Scheme
;; fannkuch benchmark for The Computer Language Shootout
|
|
;; Written by Dima Dorfman, 2004
|
|
;; Slightly improved by Sven Hartrumpf, 2005-2006
|
|
;; Ever-so-slightly tweaked for MzScheme by Brent Fulgham
|
|
;; PLT-ized for v4.0 by Matthew
|
|
|
|
#lang scheme/base
|
|
(require scheme/cmdline)
|
|
|
|
(define (fannkuch n)
|
|
(let ([pi (list->vector
|
|
(for/list ([i (in-range n)]) i))]
|
|
[tmp (make-vector n)]
|
|
[count (make-vector n)])
|
|
(let loop ([flips 0]
|
|
[perms 0]
|
|
[r n])
|
|
(when (< perms 30)
|
|
(for ([x (in-vector pi)])
|
|
(display (add1 x)))
|
|
(newline))
|
|
(for ([i (in-range r)])
|
|
(vector-set! count i (add1 i)))
|
|
(let ((flips2 (max (count-flips pi tmp) flips)))
|
|
(let loop2 ([r 1])
|
|
(if (= r n)
|
|
flips2
|
|
(let ((perm0 (vector-ref pi 0)))
|
|
(for ([i (in-range r)])
|
|
(vector-set! pi i (vector-ref pi (add1 i))))
|
|
(vector-set! pi r perm0)
|
|
(vector-set! count r (sub1 (vector-ref count r)))
|
|
(cond
|
|
[(<= (vector-ref count r) 0)
|
|
(loop2 (add1 r))]
|
|
[else (loop flips2 (add1 perms) r)]))))))))
|
|
|
|
(define (count-flips pi rho)
|
|
(vector-copy! rho 0 pi)
|
|
(let loop ([i 0])
|
|
(if (= (vector-ref rho 0) 0)
|
|
i
|
|
(begin
|
|
(vector-reverse-slice! rho 0 (add1 (vector-ref rho 0)))
|
|
(loop (add1 i))))))
|
|
|
|
(define (vector-reverse-slice! v i j)
|
|
(let loop ([i i]
|
|
[j (sub1 j)])
|
|
(when (> j i)
|
|
(vector-swap! v i j)
|
|
(loop (add1 i) (sub1 j)))))
|
|
|
|
(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)))
|
|
|
|
(command-line #:args (n)
|
|
(printf "Pfannkuchen(~a) = ~a\n"
|
|
n
|
|
(fannkuch (string->number n))))
|