shootout benchmark improvements

svn: r10837

collects/tests/mzscheme/benchmarks/shootout/chameneos.ss

@@ -14,9 +14,9 @@
     [(blue)
      (case c2 [(yellow) 'red] [(red) 'yellow] [else c1])]))
   
-(for* ([a '(blue red yellow)]
-       [b '(blue red yellow)])
-  (printf "~a + ~a -> ~a\n" a b (change a b)))
+(let ([colors '(blue red yellow)])
+  (for* ([a colors][b colors])
+    (printf "~a + ~a -> ~a\n" a b (change a b))))
 
 (define (place meeting-ch n)
   (thread

collects/tests/mzscheme/benchmarks/shootout/fannkuch.ss

@@ -1,80 +1,61 @@
-#!/usr/bin/mzscheme -qu
 ;; 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 vector-for-each (lambda (pred v)
-                          (do ((i 0 (add1 i))
-                               (v-length (vector-length v)))
-                              ((>= i v-length))
-                            (pred (vector-ref v i)))))
+(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)
-  (do ((i i (add1 i))
-       (j (sub1 j) (sub1 j))) ; exclude position j
-      ((<= j i))
-    (vector-swap! 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)))
 
-(define (count-flips pi)
-  (do ((rho (vector-copy pi))
-       (i 0 (add1 i)))
-      ((= (vector-ref rho 0) 0) i)
-    (vector-reverse-slice! rho 0 (add1 (vector-ref rho 0)))))
-
-(define (vector-copy source)
-  (let ([vec (make-vector (vector-length source))])
-    (vector-copy! vec 0 source)
-    vec))
-
-(define (fannkuch n)
-  (let ((pi (do ((pi (make-vector n))
-                 (i 0 (add1 i)))
-                ((= i n) pi)
-              (vector-set! pi i i)))
-        (r n)
-        (count (make-vector n)))
-    (let loop ((flips 0)
-               (perms 0))
-      (cond ((< perms 30)
-             (vector-for-each (lambda (x)
-                                (display (add1 x)))
-                              pi)
-             (newline)))
-      (do ()
-          ((= r 1))
-        (vector-set! count (sub1 r) r)
-        (set! r (sub1 r)))
-      (let ((flips2 (max (count-flips pi) flips)))
-        (let ((result
-               (let loop2 ()
-                 (if (= r n)
-                     flips2
-                     (let ((perm0 (vector-ref pi 0)))
-                       (do ((i 0))
-                           ((>= i r))
-                         (let ((j (add1 i)))
-                           (vector-set! pi i (vector-ref pi j))
-                           (set! i j)))
-                       (vector-set! pi r perm0)
-                       (vector-set! count r (sub1 (vector-ref count r)))
-                       (cond ((<= (vector-ref count r) 0)
-                              (set! r (add1 r))
-                              (loop2))
-                             (else
-                              #f)))))))
-          (or result
-              (loop flips2 (add1 perms))))))))
-
 (command-line #:args (n)
               (printf "Pfannkuchen(~a) = ~a\n" 
                       n 

collects/tests/mzscheme/benchmarks/shootout/fasta.ss

@@ -46,11 +46,9 @@
 
 (define (make-cumulative-table frequency-table)
   (let ([cumulative 0.0])
-    (map
-     (lambda (x) 
+    (for/list ([x frequency-table])
       (set! cumulative (+ cumulative (cdr x))) 
-       (cons (char->integer (car x)) cumulative))
-     frequency-table)))
+      (cons (char->integer (car x)) cumulative))))
 
 ;; -------------
 
@@ -61,12 +59,10 @@
 
 (define (select-random cumulative-table)
   (let ((rvalue (random-next 1.0)))
-    (select-over-threshold rvalue cumulative-table)))
-
-(define (select-over-threshold rvalue table)
+    (let select-over-threshold ([table cumulative-table])
       (if (<= rvalue (cdar table))
           (caar table)
-      (select-over-threshold rvalue (cdr table))))
+          (select-over-threshold (cdr table))))))
 
 ;; -------------
 
@@ -93,13 +89,10 @@
     (display (string-append +segmarker+ id " " desc "\n") out)
     (let loop-o ((n n_))
       (unless (<= n 0)
-        (let ((m (min n line-length)))
-          (let loop-i ((i 0))
-            (unless (>= i m)
-              (write-byte (select-random cumulative-table) out)
-              (loop-i (add1 i))))
+        (for ([i (in-range (min n line-length))])
+          (write-byte (select-random cumulative-table) out))
         (newline out)
-          (loop-o (- n line-length)))))))
+        (loop-o (- n line-length))))))
 
 ;; -------------------------------