add chameneos-redux benchmark

extra/benchmark/chameneos-redux/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/benchmark/chameneos-redux/chameneos-redux.factor

@@ -0,0 +1,106 @@
+! 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