--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators
+concurrency.mailboxes fry io kernel make math math.parser
+math.text.english sequences threads ;
+IN: benchmark.chameneos-redux
+
+SYMBOLS: red yellow blue ;
+
+ERROR: bad-color-pair pair ;
+
+TUPLE: creature n color count self-count mailbox ;
+
+TUPLE: meeting-place count mailbox ;
+
+: <meeting-place> ( count -- meeting-place )
+ meeting-place new
+ swap >>count
+ <mailbox> >>mailbox ;
+
+: <creature> ( n color -- creature )
+ creature new
+ swap >>color
+ swap >>n
+ 0 >>count
+ 0 >>self-count
+ <mailbox> >>mailbox ;
+
+: make-creatures ( colors -- seq )
+ [ length iota ] [ ] bi [ <creature> ] 2map ;
+
+: complement-color ( color1 color2 -- color3 )
+ 2dup = [ drop ] [
+ 2array {
+ { { red yellow } [ blue ] }
+ { { red blue } [ yellow ] }
+ { { yellow red } [ blue ] }
+ { { yellow blue } [ red ] }
+ { { blue red } [ yellow ] }
+ { { blue yellow } [ red ] }
+ [ bad-color-pair ]
+ } case
+ ] if ;
+
+: color-string ( color1 color2 -- string )
+ [
+ [ [ name>> ] bi@ " + " glue % " -> " % ]
+ [ complement-color name>> % ] 2bi
+ ] "" make ;
+
+: print-color-table ( -- )
+ { blue red yellow } dup
+ '[ _ '[ color-string print ] with each ] each ;
+
+: try-meet ( meeting-place creature -- )
+ over count>> 0 < [
+ 2drop
+ ] [
+ [ swap mailbox>> mailbox-put ]
+ [ nip mailbox>> mailbox-get drop ]
+ [ try-meet ] 2tri
+ ] if ;
+
+: creature-meeting ( seq -- )
+ first2 {
+ [ [ [ 1 + ] change-count ] bi@ 2drop ]
+ [ 2dup = [ [ 1 + ] change-self-count ] when 2drop ]
+ [ [ [ color>> ] bi@ complement-color ] [ [ (>>color) ] bi-curry@ bi ] 2bi ]
+ [ [ mailbox>> f swap mailbox-put ] bi@ ]
+ } 2cleave ;
+
+: run-meeting-place ( meeting-place -- )
+ [ 1 - ] change-count
+ dup count>> 0 < [
+ mailbox>> mailbox-get-all
+ [ f swap mailbox>> mailbox-put ] each
+ ] [
+ [ mailbox>> 2 swap '[ _ mailbox-get ] replicate creature-meeting ]
+ [ run-meeting-place ] bi
+ ] if ;
+
+: number>chameneos-string ( n -- string )
+ number>string string>digits [ number>text ] { } map-as " " join ;
+
+: chameneos-redux ( n colors -- )
+ [ <meeting-place> ] [ make-creatures ] bi*
+ {
+ [ nip nl bl [ bl ] [ color>> name>> write ] interleave nl ]
+ [ [ '[ _ _ try-meet ] in-thread ] with each ]
+ [ drop run-meeting-place ]
+
+ [ nip [ [ count>> number>string write bl ] [ self-count>> number>text write nl ] bi ] each ]
+ [ nip 0 [ count>> + ] reduce bl number>chameneos-string print ]
+ } 2cleave ;
+
+! 6000000 for shootout, too slow right now
+
+: chameneos-redux-main ( -- )
+ print-color-table
+ 60000 [
+ { blue red yellow } chameneos-redux
+ ] [
+ { blue red yellow red yellow blue red yellow red blue } chameneos-redux
+ ] bi ;
+
+MAIN: chameneos-redux-main