From b8aa628d1e5c9f00c5c63ae258203b9f0948537c Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 19 Jul 2008 00:11:10 +0000
Subject: [PATCH] shootout updates

svn: r10836
---
 .../benchmarks/shootout/binarytrees.ss        | 16 ++--
 .../mzscheme/benchmarks/shootout/chameneos.ss | 90 +++++++++++++------
 2 files changed, 73 insertions(+), 33 deletions(-)

diff --git a/collects/tests/mzscheme/benchmarks/shootout/binarytrees.ss b/collects/tests/mzscheme/benchmarks/shootout/binarytrees.ss
index 33b4ed86b2..335a5687e3 100644
--- a/collects/tests/mzscheme/benchmarks/shootout/binarytrees.ss
+++ b/collects/tests/mzscheme/benchmarks/shootout/binarytrees.ss
@@ -21,7 +21,8 @@
 (define (check t)
   (if (leaf? t)
       (leaf-val t)
-      (+ (node-val t) (- (check (node-left t)) (check (node-right t))))))
+      (+ (node-val t) (- (check (node-left t)) 
+                         (check (node-right t))))))
 
 (define (main n)
   (let* ((min-depth 4)
@@ -31,17 +32,16 @@
               stretch-depth
               (check (make 0 stretch-depth))))
     (let ((long-lived-tree (make 0 max-depth)))
-      (do ((d 4 (+ d 2))
-           (c 0 0))
-          ((> d max-depth))
+      (for ((d (in-range 4 (add1 max-depth) 2)))
         (let ((iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth))))
-          (do ((i 0 (+ i 1)))
-              ((>= i iterations))
-            (set! c (+ c (check (make i d)) (check (make (- i) d)))))
           (printf "~a\t trees of depth ~a\t check: ~a\n"
                   (* 2 iterations)
                   d
-                  c)))
+                  (for/fold ([c 0])
+                            ([i (in-range iterations)])
+                    (+ c 
+                       (check (make i d)) 
+                       (check (make (- i) d)))))))
       (printf "long lived tree of depth ~a\t check: ~a\n"
               max-depth
               (check long-lived-tree)))))
diff --git a/collects/tests/mzscheme/benchmarks/shootout/chameneos.ss b/collects/tests/mzscheme/benchmarks/shootout/chameneos.ss
index 7a41a50289..52ef341eb2 100644
--- a/collects/tests/mzscheme/benchmarks/shootout/chameneos.ss
+++ b/collects/tests/mzscheme/benchmarks/shootout/chameneos.ss
@@ -2,7 +2,8 @@
 ;;; http://shootout.alioth.debian.org/
 
 #lang scheme/base
-(require scheme/cmdline)
+(require scheme/cmdline
+         scheme/match)
 
 (define (change c1 c2)
   (case c1
@@ -13,6 +14,10 @@
     [(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)))
+
 (define (place meeting-ch n)
   (thread
    (lambda ()
@@ -24,33 +29,68 @@
                (channel-put (car c) #f)
                (loop)))
            ;; Let two meet:
-           (let ([c1 (channel-get meeting-ch)]
-                 [c2 (channel-get meeting-ch)])
-             (channel-put (car c1) (cdr c2))
-             (channel-put (car c2) (cdr c1))
+           (match-let ([(cons ch1 v1) (channel-get meeting-ch)]
+                       [(cons ch2 v2) (channel-get meeting-ch)])
+             (channel-put ch1 v2)
+             (channel-put ch2 v1)
              (loop (sub1 n))))))))
 
 (define (creature color meeting-ch result-ch)
   (thread 
    (lambda ()
-     (let ([ch (make-channel)])
-       (let loop ([color color][met 0])
-         (channel-put meeting-ch (cons ch color))
-         (let ([other-color (channel-get ch)])
-           (if other-color
-               ;; Meet:
-               (loop (change color other-color) (add1 met))
-               ;; Done:
-               (channel-put result-ch met))))))))
+     (let ([ch (make-channel)]
+           [name (gensym)])
+       (let loop ([color color][met 0][same 0])
+         (channel-put meeting-ch (cons ch (cons color name)))
+         (match (channel-get ch)
+           [(cons other-color other-name)
+            ;; Meet:
+            (loop (change color other-color) 
+                  (add1 met)
+                  (+ same (if (eq? name other-name)
+                              1
+                              0)))]
+           [#f
+            ;; Done:
+            (channel-put result-ch (cons met same))]))))))
 
-(let ([result-ch (make-channel)]
-      [meeting-ch (make-channel)])
-  (place meeting-ch (command-line #:args (n) (string->number n)))
-  (creature 'blue meeting-ch result-ch)
-  (creature 'red meeting-ch result-ch)
-  (creature 'yellow meeting-ch result-ch)
-  (creature 'blue meeting-ch result-ch)
-  (printf "~a\n" (+ (channel-get result-ch)
-                    (channel-get result-ch)
-                    (channel-get result-ch)
-                    (channel-get result-ch))))
+(define (spell n)
+  (for ([i (number->string n)])
+    (display " ")
+    (display (hash-ref digits i))))
+  
+(define digits
+  #hash((#\0 . "zero")
+        (#\1 . "one")
+        (#\2 . "two")
+        (#\3 . "three")
+        (#\4 . "four")
+        (#\5 . "five")
+        (#\6 . "six")
+        (#\7 . "seven")
+        (#\8 . "eight")
+        (#\9 . "nine")))
+
+(define (go n inits)
+  (let ([result-ch (make-channel)]
+        [meeting-ch (make-channel)])
+    (place meeting-ch n)
+    (newline)
+    (for ([init inits])
+      (printf " ~a" init)
+      (creature init meeting-ch result-ch))
+    (newline)
+    (let ([results (for/list ([i inits])
+                     (channel-get result-ch))])
+      (for ([r results])
+        (display (car r))
+        (spell (cdr r))
+        (newline))
+      (spell (apply + (map car results)))
+      (newline))))
+
+(let ([n (command-line #:args (n) (string->number n))])
+  (go n '(blue red yellow))
+  (go n '(blue red yellow red yellow blue red yellow red blue)))
+
+