Added the fannkuch-redux benchmark, which replaced fannkuch on the

shootout roster.

collects/tests/racket/benchmarks/shootout/auto.rkt

@@ -117,6 +117,7 @@ exec racket -qu "$0" ${1+"$@"}
       echo
       except
       fannkuch
+      fannkuch-redux
       fasta
       fibo
       hash

collects/tests/racket/benchmarks/shootout/fannkuch-redux.rkt

@@ -0,0 +1,59 @@
+#lang racket/base
+
+;; 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
+
+(require racket/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])
+      (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))))

collects/tests/racket/benchmarks/shootout/run.rkt

@@ -11,6 +11,7 @@
       ("echo" "200000")
       ("except" "2000000")
       ("fannkuch" "10")
+      ("fannkuch-redux" "10")
       ("fasta" "1000000")
       ("fibo" "40")
       ("hash" "2000000")

collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-non-optimizing.rkt

@@ -0,0 +1,2 @@
+
+(module fannkuch-redux-non-optimizing "wrap-typed-non-optimizing.ss")

collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-optimizing.rkt

@@ -0,0 +1,2 @@
+
+(module fannkuch-redux-optimizing "wrap-typed-optimizing.ss")

collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux.rktl

@@ -0,0 +1,64 @@
+;; 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
+;; Ported to Typed Scheme by Vincent
+
+(require racket/cmdline)
+
+(: fannkuch (Integer -> Integer))
+(define (fannkuch n)
+  (let ([pi (list->vector 
+             (for/list: : (Listof Integer) ([i : Integer (in-range n)]) i))]
+        [tmp (make-vector n)]
+        [count (make-vector n)])
+    (let: loop : Integer
+          ([flips : Integer 0]
+           [perms : Integer 0]
+           [r : Integer n])
+      (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)]))))))))
+
+(: count-flips ((Vectorof Integer) (Vectorof Integer) -> Integer))
+(define (count-flips pi rho)
+  (vector-copy! rho 0 pi)
+  (let: loop : Integer ([i : Integer 0])
+    (if (= (vector-ref rho 0) 0)
+        i
+        (begin
+          (vector-reverse-slice! rho 0 (add1 (vector-ref rho 0)))
+          (loop (add1 i))))))
+
+(: vector-reverse-slice! (All (X) ((Vectorof X) Integer Integer -> Void)))
+(define (vector-reverse-slice! v i j)
+  (let: loop : Void
+        ([i : Integer i]
+         [j : Integer (sub1 j)])
+    (when (> j i)
+      (vector-swap! v i j)
+      (loop (add1 i) (sub1 j)))))
+
+(: vector-swap! (All (X) ((Vectorof X) Integer Integer -> Void)))
+(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 (assert (string->number (assert n string?)) exact-nonnegative-integer?))))