1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators
4 concurrency.mailboxes fry io kernel make math math.parser
5 math.text.english sequences threads ;
6 IN: benchmark.chameneos-redux
8 SYMBOLS: red yellow blue ;
10 ERROR: bad-color-pair pair ;
12 TUPLE: creature n color count self-count mailbox ;
14 TUPLE: meeting-place count mailbox ;
16 : <meeting-place> ( count -- meeting-place )
21 : <creature> ( n color -- creature )
29 : make-creatures ( colors -- seq )
30 [ length <iota> ] [ ] bi [ <creature> ] 2map ;
32 : complement-color ( color1 color2 -- color3 )
35 { { red yellow } [ blue ] }
36 { { red blue } [ yellow ] }
37 { { yellow red } [ blue ] }
38 { { yellow blue } [ red ] }
39 { { blue red } [ yellow ] }
40 { { blue yellow } [ red ] }
45 : color-string ( color1 color2 -- string )
47 [ [ name>> ] bi@ " + " glue % " -> " % ]
48 [ complement-color name>> % ] 2bi
51 : print-color-table ( -- )
52 { blue red yellow } dup
53 '[ _ '[ color-string print ] with each ] each ;
55 : try-meet ( meeting-place creature -- )
59 [ swap mailbox>> mailbox-put ]
60 [ nip mailbox>> mailbox-get drop ]
64 : creature-meeting ( seq -- )
66 [ [ [ 1 + ] change-count ] bi@ 2drop ]
67 [ 2dup = [ [ 1 + ] change-self-count ] when 2drop ]
68 [ [ [ color>> ] bi@ complement-color ] [ [ color<< ] bi-curry@ bi ] 2bi ]
69 [ [ mailbox>> f swap mailbox-put ] bi@ ]
72 : run-meeting-place ( meeting-place -- )
75 mailbox>> mailbox-get-all
76 [ f swap mailbox>> mailbox-put ] each
78 [ mailbox>> 2 swap '[ _ mailbox-get ] replicate creature-meeting ]
79 [ run-meeting-place ] bi
82 : number>chameneos-string ( n -- string )
83 number>string string>digits [ number>text ] { } map-as " " join ;
85 : chameneos-redux ( n colors -- )
86 [ <meeting-place> ] [ make-creatures ] bi*
88 [ nip nl bl [ bl ] [ color>> name>> write ] interleave nl ]
89 [ [ '[ _ _ try-meet ] in-thread ] with each ]
90 [ drop run-meeting-place ]
92 [ nip [ [ count>> number>string write bl ] [ self-count>> number>text write nl ] bi ] each ]
93 [ nip [ count>> ] map-sum bl number>chameneos-string print ]
96 ! 6000000 for shootout, too slow right now
98 : chameneos-redux-benchmark ( -- )
101 { blue red yellow } chameneos-redux
103 { blue red yellow red yellow blue red yellow red blue } chameneos-redux
106 MAIN: chameneos-redux-benchmark