apps/automata.factor

   1 REQUIRES: libs/vars libs/slate apps/lindenmayer/opengl ;
   2
   3 USING: kernel namespaces hashtables sequences generic math arrays
   4        threads opengl gadgets
   5        vars slate opengl-contrib ;
   6
   7 IN: automata
   8
   9 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  10 ! set-rule
  11 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  12
  13 : char>digit ( c -- i ) 48 - ;
  14
  15 : string>digits ( s -- seq ) >array [ char>digit ] map ;
  16
  17 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  18
  19 VAR: rule   VAR: rule-number
  20
  21 : init-rule ( -- ) 8 <hashtable> >rule ;
  22
  23 : rule-keys ( -- array )
  24 { { 1 1 1 }
  25   { 1 1 0 }
  26   { 1 0 1 }
  27   { 1 0 0 }
  28   { 0 1 1 }
  29   { 0 1 0 }
  30   { 0 0 1 }
  31   { 0 0 0 } } ;
  32
  33 : rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-left string>digits ;
  34
  35 : set-rule ( n -- )
  36 dup >rule-number rule-values rule-keys [ rule> set-hash ] 2each ;
  37
  38 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  39 ! step-capped-line
  40 ! step-wrapped-line
  41 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  42
  43 : 3nth ( n seq -- slice ) >r dup 3 + r> <slice> ;
  44
  45 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  46
  47 : map3-i ( seq -- i ) length 2 - ;
  48
  49 : map3-quot ( quot -- quot ) [ swap 3nth ] swap append ;
  50
  51 : map3 ( seq quot -- seq ) over map3-i swap map3-quot map-with ;
  52
  53 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  54
  55 : pattern>state ( {_a_b_c_} -- state ) rule> hash ;
  56
  57 : cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ;
  58
  59 : wrap-line ( a-line-z -- za-line-za )
  60 dup peek 1array swap dup first 1array append append ;
  61
  62 : step-line ( line -- new-line ) [ >array pattern>state ] map3 ;
  63
  64 : step-capped-line ( line -- new-line ) cap-line step-line ;
  65
  66 : step-wrapped-line ( line -- new-line ) wrap-line step-line ;
  67
  68 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  69
  70 : window-width ( -- width ) slate> rect-dim 0 swap nth ;
  71
  72 : window-height ( -- height ) slate> rect-dim 1 swap nth ;
  73
  74 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  75
  76 : random-line ( -- line ) window-width [ drop 2 random-int ] map ;
  77
  78 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  79
  80 : center-i ( -- i ) window-width 2 / >fixnum ;
  81
  82 : center-line ( -- line ) center-i window-width [ = [ 1 ] [ 0 ] if ] map-with ;
  83
  84 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  85
  86 : random-item ( seq -- item ) dup length random-int swap nth ;
  87
  88 : interesting ( -- seq )
  89 { 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
  90   110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
  91
  92 : mild ( -- seq )
  93 { 6 9 11 57 62 74 118 } ;
  94
  95 : set-interesting ( -- ) interesting random-item set-rule ;
  96
  97 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  98
  99 VAR: bitmap
 100
 101 VAR: last-line
 102
 103 : run-rule ( -- )
 104 last-line> window-height [ drop step-capped-line dup ] map >bitmap >last-line
 105 .slate ;
 106
 107 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 108
 109 : start-random ( -- ) random-line >last-line run-rule ;
 110
 111 : start-center ( -- ) center-line >last-line run-rule ;
 112
 113 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 114
 115 : draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
 116
 117 : draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
 118
 119 : (draw-bitmap) ( bitmap -- ) 0 swap [ >r dup r> draw-line 1+ ] each drop ;
 120
 121 : draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
 122
 123 : display ( -- )
 124 GL_COLOR_BUFFER_BIT glClear black gl-color bitmap> draw-bitmap ;
 125
 126 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 127
 128 : init-slate ( -- )
 129 <slate> >slate   namespace slate> set-slate-ns   [ display ] >action ;
 130
 131 : init ( -- ) init-rule init-slate ;
 132
 133 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 134
 135 VAR: loop-flag
 136
 137 DEFER: loop
 138
 139 : (loop) ( -- ) run-rule 3000 sleep loop ;
 140
 141 : loop ( -- ) loop-flag> [ (loop) ] [ ] if ;
 142
 143 : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
 144
 145 : stop-loop ( -- ) f >loop-flag ;
 146
 147 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 148
 149 TUPLE: automata-gadget ;
 150
 151 C: automata-gadget ( -- automata-gadget )
 152 init
 153 slate> over set-delegate
 154 interesting random-item set-rule ;
 155
 156 : automata-window ( -- ) <automata-gadget> "Automata" open-titled-window ;
 157
 158 automata-gadget H{
 159     { T{ key-down f f "1" } [ slate-ns [ start-center    ] bind ] }
 160     { T{ key-down f f "2" } [ slate-ns [ start-random    ] bind ] }
 161     { T{ key-down f f "3" } [ slate-ns [ run-rule        ] bind ] }
 162     { T{ key-down f f "5" }
 163       [ slate-ns [ set-interesting start-center ] bind ] }
 164     { T{ key-down f f "9" } [ slate-ns [ start-loop ] bind ] }
 165     { T{ key-down f f "0" } [ slate-ns [ stop-loop ] bind ] }
 166 } set-gestures
 167
 168 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 169
 170 PROVIDE: apps/automata ;