suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

shootout updates

Browse Source 
svn: r10836
This commit is contained in:
Matthew Flatt 2008-07-19 00:11:10 +00:00
parent 69d604c0be
commit b8aa628d1e
2 changed files with 73 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/tests/mzscheme/benchmarks/shootout/binarytrees.ss
View File

@ -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)))))

90
collects/tests/mzscheme/benchmarks/shootout/chameneos.ss
View File

@ -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))]))))))
(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)))
(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))))