mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 06:09:18 +02:00
7b23858d86
Previously (command-line) did not include the script name, but did include the executable name if no script was given. Now if a script is given its name will be the first element of the list returned by (command-line) and will be the first element of the list passed to (main). This brings us into compliance with SRFI-22. Our man page was already correct on this point.
107 lines
2.9 KiB
Text
107 lines
2.9 KiB
Text
#! /usr/bin/env chibi-scheme
|
|
|
|
;;; The Computer Language Benchmarks Game
|
|
;;; http://shootout.alioth.debian.org/
|
|
|
|
;;; based on Racket version by Matthew Flatt
|
|
|
|
(import (scheme)
|
|
(srfi 18)
|
|
(chibi match))
|
|
|
|
(define (print . args)
|
|
(for-each display args)
|
|
(newline))
|
|
|
|
(define (change c1 c2)
|
|
(case c1
|
|
((red)
|
|
(case c2 ((blue) 'yellow) ((yellow) 'blue) (else c1)))
|
|
((yellow)
|
|
(case c2 ((blue) 'red) ((red) 'blue) (else c1)))
|
|
((blue)
|
|
(case c2 ((yellow) 'red) ((red) 'yellow) (else c1)))))
|
|
|
|
(let ((colors '(blue red yellow)))
|
|
(for-each
|
|
(lambda (a)
|
|
(for-each
|
|
(lambda (b)
|
|
(print a " + " b " -> " (change a b)))
|
|
colors))
|
|
colors))
|
|
|
|
(define (place meeting-ch n)
|
|
(thread-start!
|
|
(make-thread
|
|
(lambda ()
|
|
(let loop ((n n))
|
|
(if (<= n 0)
|
|
;; Fade all:
|
|
(let loop ()
|
|
(let ((c (channel-get meeting-ch)))
|
|
(channel-put (car c) #f)
|
|
(loop)))
|
|
;; Let two meet:
|
|
(match-let (((ch1 . v1) (channel-get meeting-ch))
|
|
((ch2 . v2) (channel-get meeting-ch)))
|
|
(channel-put ch1 v2)
|
|
(channel-put ch2 v1)
|
|
(loop (- n 1)))))))))
|
|
|
|
(define (creature color meeting-ch result-ch)
|
|
(thread-start!
|
|
(make-thread
|
|
(lambda ()
|
|
(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)
|
|
((other-color . other-name)
|
|
;; Meet:
|
|
(sleep) ; avoid imbalance from weak fairness
|
|
(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-each
|
|
(lambda (i)
|
|
(display " ")
|
|
(display (vector-ref digits (- (char->integer i) (char->integer #\0)))))
|
|
(string->list (number->string n))))
|
|
|
|
(define digits
|
|
'#("zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
|
|
|
|
(define (go n inits)
|
|
(let ((result-ch (make-channel))
|
|
(meeting-ch (make-channel)))
|
|
(place meeting-ch n)
|
|
(newline)
|
|
(for-each
|
|
(lambda (init)
|
|
(print " " init)
|
|
(creature init meeting-ch result-ch))
|
|
inits)
|
|
(newline)
|
|
(let ((results (map (lambda (i) (channel-get result-ch)) inits)))
|
|
(for-each
|
|
(lambda (r)
|
|
(display (car r))
|
|
(spell (cdr r))
|
|
(newline))
|
|
results)
|
|
(spell (apply + (map car results)))
|
|
(newline))))
|
|
|
|
(let ((n (string->number (cadr (command-line)))))
|
|
(go n '(blue red yellow))
|
|
(go n '(blue red yellow red yellow blue red yellow red blue))
|
|
(newline))
|