The Computer Language
Benchmarks Game

chameneos-redux Racket #2 program

source code

#lang racket/base

;;; The Computer Language Benchmarks Game
;;; http://benchmarksgame.alioth.debian.org/

;;; contributed by Matthew Flatt
;;; modified by HN
;;;
;;; Uses Racket threads

(require racket/cmdline
         racket/match)

(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* ([a colors][b colors])
    (printf "~a + ~a -> ~a\n" a b (change a b))))

(define (place meeting-ch n custodian)
  (parameterize ([current-custodian custodian])
    (thread
     (lambda ()
       (let loop ([n n])
         (if (zero? n)
             ;; Fade all:
             (let loop ()
               (let ([c (channel-get meeting-ch)])
                 (channel-put (car c) #f)
                 (loop)))
             ;; Let two meet:
             (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 custodian)
  (parameterize ([current-custodian custodian])
    (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)
             [(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)]
        [custodian (make-custodian)])
    (place meeting-ch n custodian)
    (newline)
    (for ([init inits])
      (printf " ~a" init)
      (creature init meeting-ch result-ch custodian))
    (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))
    (custodian-shutdown-all custodian)))

(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))
  (newline))
    

notes, command-line, and program output

NOTES:
32-bit Ubuntu one core
Welcome to Racket v6.6.


Sat, 23 Jul 2016 19:25:53 GMT

MAKE:
/usr/local/src/racket-6.6/bin/raco make chameneosredux.racket-2.racket
0.86s to complete and log all make actions

COMMAND LINE:
/usr/local/src/racket-6.6/bin/racket ./compiled/chameneosredux.racket-2_racket.zo 6000000

PROGRAM OUTPUT:
blue + blue -> blue
blue + red -> yellow
blue + yellow -> red
red + blue -> yellow
red + red -> red
red + yellow -> blue
yellow + blue -> red
yellow + red -> blue
yellow + yellow -> yellow

 blue red yellow
4000000 zero
4000000 zero
4000000 zero
 one two zero zero zero zero zero zero

 blue red yellow red yellow blue red yellow red blue
1200023 zero
1200023 zero
1200024 zero
1200023 zero
1200024 zero
1200024 zero
1200024 zero
1200024 zero
1199787 zero
1200024 zero
 one two zero zero zero zero zero zero