diff --git a/extra/benchmark/chameneos-redux/authors.txt b/extra/benchmark/chameneos-redux/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/benchmark/chameneos-redux/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/benchmark/chameneos-redux/chameneos-redux.factor b/extra/benchmark/chameneos-redux/chameneos-redux.factor new file mode 100644 index 0000000000..afd2f8830a --- /dev/null +++ b/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 ; + +: ( count -- meeting-place ) + meeting-place new + swap >>count + >>mailbox ; + +: ( n color -- creature ) + creature new + swap >>color + swap >>n + 0 >>count + 0 >>self-count + >>mailbox ; + +: make-creatures ( colors -- seq ) + [ length iota ] [ ] bi [ ] 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 -- ) + [ ] [ 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