contrib/automata.factor

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