shootout updates

svn: r10836

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))
+      (for ((d (in-range 4 (add1 max-depth) 2)))
-           (c 0 0))
-          ((> d max-depth))
         (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)))))

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)]
+           (match-let ([(cons ch1 v1) (channel-get meeting-ch)]
-                 [c2 (channel-get meeting-ch)])
+                       [(cons ch2 v2) (channel-get meeting-ch)])
-             (channel-put (car c1) (cdr c2))
+             (channel-put ch1 v2)
-             (channel-put (car c2) (cdr c1))
+             (channel-put ch2 v1)
              (loop (sub1 n))))))))
 
 (define (creature color meeting-ch result-ch)
   (thread 
    (lambda ()
-     (let ([ch (make-channel)])
+     (let ([ch (make-channel)]
-       (let loop ([color color][met 0])
+           [name (gensym)])
-         (channel-put meeting-ch (cons ch color))
+       (let loop ([color color][met 0][same 0])
-         (let ([other-color (channel-get ch)])
+         (channel-put meeting-ch (cons ch (cons color name)))
-           (if other-color
+         (match (channel-get ch)
+           [(cons other-color other-name)
             ;; Meet:
-               (loop (change color other-color) (add1 met))
+            (loop (change color other-color) 
+                  (add1 met)
+                  (+ same (if (eq? name other-name)
+                              1
+                              0)))]
+           [#f
             ;; Done:
-               (channel-put result-ch met))))))))
+            (channel-put result-ch (cons met same))]))))))
 
+(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 (command-line #:args (n) (string->number n)))
+    (place meeting-ch n)
-  (creature 'blue meeting-ch result-ch)
+    (newline)
-  (creature 'red meeting-ch result-ch)
+    (for ([init inits])
-  (creature 'yellow meeting-ch result-ch)
+      (printf " ~a" init)
-  (creature 'blue meeting-ch result-ch)
+      (creature init meeting-ch result-ch))
-  (printf "~a\n" (+ (channel-get result-ch)
+    (newline)
-                    (channel-get result-ch)
+    (let ([results (for/list ([i inits])
-                    (channel-get result-ch)
+                     (channel-get result-ch))])
-                    (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)))
+
+