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

107 lines
3.0 KiB
Factor

! 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