unmaintained/automata/automata.factor

   1
   2 USING: kernel math math.parser random arrays hashtables assocs sequences
   3        grouping vars ;
   4
   5 IN: automata
   6
   7 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   8 ! set-rule
   9 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  10
  11 VAR: rule   VAR: rule-number
  12
  13 : init-rule ( -- ) 8 <hashtable> >rule ;
  14
  15 : rule-keys ( -- array )
  16   { { 1 1 1 }
  17     { 1 1 0 }
  18     { 1 0 1 }
  19     { 1 0 0 }
  20     { 0 1 1 }
  21     { 0 1 0 }
  22     { 0 0 1 }
  23     { 0 0 0 } } ;
  24
  25 : rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-head string>digits ;
  26
  27 : set-rule ( n -- )
  28   dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
  29
  30 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  31 ! step-capped-line
  32 ! step-wrapped-line
  33 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  34
  35 : pattern>state ( {_a_b_c_} -- state ) rule> at ;
  36
  37 : cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
  38
  39 : wrap-line ( a-line-z -- za-line-za )
  40   dup peek 1array swap dup first 1array append append ;
  41
  42 : step-line ( line -- new-line ) 3 <clumps> [ pattern>state ] map ;
  43
  44 : step-capped-line  ( line -- new-line ) cap-line  step-line ;
  45 : step-wrapped-line ( line -- new-line ) wrap-line step-line ;
  46
  47 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  48
  49 VARS: width height ;
  50
  51 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  52
  53 : random-line ( -- line ) width> [ drop 2 random ] map ;
  54
  55 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  56
  57 : center-i ( -- i ) width> 2 / >fixnum ;
  58
  59 : center-line ( -- line ) center-i width> [ = 1 0 ? ] with map ;
  60
  61 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  62
  63 : interesting ( -- seq )
  64   { 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
  65     110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
  66
  67 : mild ( -- seq ) { 6 9 11 57 62 74 118 } ;
  68
  69 : set-interesting ( -- ) interesting random set-rule ;
  70
  71 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  72
  73 VAR: bitmap
  74
  75 VAR: last-line
  76
  77 : run-rule ( -- )
  78   last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
  79
  80 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  81
  82 : start-random ( -- ) random-line >last-line run-rule ;
  83
  84 : start-center ( -- ) center-line >last-line run-rule ;
  85
  86 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  87
  88 ! VAR: loop-flag
  89
  90 ! DEFER: loop
  91
  92 ! : (loop) ( -- ) run-rule 3000 sleep loop ;
  93
  94 ! : loop ( -- ) loop-flag> [ (loop) ] [ ] if ;
  95
  96 ! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
  97
  98 ! : stop-loop ( -- ) f >loop-flag ;