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

   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
   7
   8 SYMBOLS: red yellow blue ;
   9
  10 ERROR: bad-color-pair pair ;
  11
  12 TUPLE: creature n color count self-count mailbox ;
  13
  14 TUPLE: meeting-place count mailbox ;
  15
  16 : <meeting-place> ( count -- meeting-place )
  17     meeting-place new
  18         swap >>count
  19         <mailbox> >>mailbox ;
  20
  21 : <creature> ( n color -- creature )
  22     creature new
  23         swap >>color
  24         swap >>n
  25         0 >>count
  26         0 >>self-count
  27         <mailbox> >>mailbox ;
  28
  29 : make-creatures ( colors -- seq )
  30     [ length <iota> ] [ ] bi [ <creature> ] 2map ;
  31
  32 : complement-color ( color1 color2 -- color3 )
  33     2dup = [ drop ] [
  34         2array {
  35             { { red yellow } [ blue ] }
  36             { { red blue } [ yellow ] }
  37             { { yellow red } [ blue ] }
  38             { { yellow blue } [ red ] }
  39             { { blue red } [ yellow ] }
  40             { { blue yellow } [ red ] }
  41             [ bad-color-pair ]
  42         } case
  43     ] if ;
  44
  45 : color-string ( color1 color2 -- string )
  46     [
  47         [ [ name>> ] bi@ " + " glue % " -> " % ]
  48         [ complement-color name>> % ] 2bi
  49     ] "" make ;
  50
  51 : print-color-table ( -- )
  52     { blue red yellow } dup
  53     '[ _ '[ color-string print ] with each ] each ;
  54
  55 : try-meet ( meeting-place creature -- )
  56     over count>> 0 < [
  57         2drop
  58     ] [
  59         [ swap mailbox>> mailbox-put ]
  60         [ nip mailbox>> mailbox-get drop ]
  61         [ try-meet ] 2tri
  62     ] if ;
  63
  64 : creature-meeting ( seq -- )
  65     first2 {
  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@ ]
  70     } 2cleave ;
  71
  72 : run-meeting-place ( meeting-place -- )
  73     [ 1 - ] change-count
  74     dup count>> 0 < [
  75         mailbox>> mailbox-get-all
  76         [ f swap mailbox>> mailbox-put ] each
  77     ] [
  78         [ mailbox>> 2 swap '[ _ mailbox-get ] replicate creature-meeting ]
  79         [ run-meeting-place ] bi
  80     ] if ;
  81
  82 : number>chameneos-string ( n -- string )
  83     number>string string>digits [ number>text ] { } map-as unwords ;
  84
  85 : chameneos-redux ( n colors -- )
  86     [ <meeting-place> ] [ make-creatures ] bi*
  87     {
  88         [ nip nl bl [ bl ] [ color>> name>> write ] interleave nl ]
  89         [ [ '[ _ _ try-meet ] in-thread ] with each ]
  90         [ drop run-meeting-place ]
  91
  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 ]
  94     } 2cleave ;
  95
  96 ! 6000000 for shootout, too slow right now
  97
  98 : chameneos-redux-benchmark ( -- )
  99     print-color-table
 100     60000 [
 101         { blue red yellow } chameneos-redux
 102     ] [
 103         { blue red yellow red yellow blue red yellow red blue } chameneos-redux
 104     ] bi ;
 105
 106 MAIN: chameneos-redux-benchmark