2006-06-18 06:04:54 -04:00
|
|
|
! Copyright (C) 2006 Eduardo Cavazos.
|
|
|
|
|
2006-07-15 06:59:55 -04:00
|
|
|
! To run:
|
2006-07-12 21:57:51 -04:00
|
|
|
! USE: automata
|
|
|
|
! automata-window
|
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
REQUIRES: math slate vars ;
|
2006-06-18 21:31:20 -04:00
|
|
|
|
2006-06-18 06:04:54 -04:00
|
|
|
USING: parser kernel hashtables namespaces sequences math io
|
2006-07-12 21:57:51 -04:00
|
|
|
math-contrib threads strings arrays prettyprint
|
2006-07-26 14:40:19 -04:00
|
|
|
gadgets gadgets-text gadgets-frames gadgets-buttons gadgets-grids
|
2006-07-12 21:57:51 -04:00
|
|
|
vars slate ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
|
|
|
IN: automata
|
|
|
|
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
! set-rule
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: char>digit ( c -- i ) 48 - ;
|
|
|
|
|
|
|
|
: string>digits ( s -- seq ) >array [ char>digit ] map ;
|
|
|
|
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
|
|
|
|
SYMBOL: rule SYMBOL: rule-number
|
2006-06-18 06:04:54 -04:00
|
|
|
|
|
|
|
: init-rule ( -- ) 8 <hashtable> rule set ;
|
|
|
|
|
|
|
|
: rule-keys ( -- { ... } )
|
2006-07-02 07:39:37 -04:00
|
|
|
{ { 1 1 1 }
|
2006-06-18 06:04:54 -04:00
|
|
|
{ 1 1 0 }
|
2006-07-02 07:39:37 -04:00
|
|
|
{ 1 0 1 }
|
|
|
|
{ 1 0 0 }
|
|
|
|
{ 0 1 1 }
|
|
|
|
{ 0 1 0 }
|
|
|
|
{ 0 0 1 }
|
|
|
|
{ 0 0 0 } } ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-left string>digits ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: set-rule ( n -- )
|
|
|
|
dup rule-number set
|
|
|
|
rule-values rule-keys [ rule get set-hash ] 2each ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
2006-07-07 02:46:14 -04:00
|
|
|
! step-capped-line
|
|
|
|
! step-wrapped-line
|
2006-06-18 06:04:54 -04:00
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
|
|
|
|
: 3nth ( n seq -- slice ) >r dup 3 + r> <slice> ;
|
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
|
|
|
|
: map3-i ( seq -- i ) length 2 - ;
|
|
|
|
|
|
|
|
: map3-quot ( quot -- quot ) [ swap 3nth ] swap append ;
|
|
|
|
|
|
|
|
: map3 ( seq quot -- seq ) over map3-i swap map3-quot map-with ;
|
|
|
|
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
|
2006-07-12 21:57:51 -04:00
|
|
|
: last ( seq -- elt ) dup length 1- swap nth ;
|
|
|
|
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: pattern>state ( { a b c } -- state ) rule get hash ;
|
|
|
|
|
|
|
|
: cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: wrap-line ( a-line-z -- za-line-za )
|
|
|
|
dup last 1array swap dup first 1array append append ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: step-line ( line -- new-line ) [ >array pattern>state ] map3 ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: step-capped-line ( line -- new-line ) cap-line step-line ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: step-wrapped-line ( line -- new-line ) wrap-line step-line ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
! Display the rule
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: random-line ( -- line ) window-width [ drop 2 random-int ] map ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: center-i ( -- i ) window-width dup 2 / >fixnum ;
|
|
|
|
|
|
|
|
: center-line ( -- line ) center-i window-width [ = [ 1 ] [ 0 ] if ] map-with ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
! show-line
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
|
|
|
|
: show-point ( { x y } p -- ) 1 = [ draw-point ] [ drop ] if ;
|
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: (show-line) ( { x y } line -- ) [ dupd show-point { 1 0 } v+ ] each drop ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: show-line ( y line -- ) 0 rot 2array swap (show-line) yield ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
2006-07-07 02:46:14 -04:00
|
|
|
! run-rule
|
|
|
|
! start-random
|
|
|
|
! start-center
|
2006-06-18 06:04:54 -04:00
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
VAR: last-line
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: estimate-capacity ( -- ) window-width window-height * 2 * capacity set ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
|
|
|
: check-capacity ( -- )
|
|
|
|
"capacity: " write capacity get number>string write terpri
|
|
|
|
"dlist length: " write dlist get length number>string write terpri ;
|
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: start-slate ( -- )
|
2006-06-18 06:04:54 -04:00
|
|
|
estimate-capacity reset-slate
|
2006-07-07 02:46:14 -04:00
|
|
|
white set-clear-color black set-color clear-window ;
|
|
|
|
|
|
|
|
: finish-slate ( -- ) check-capacity flush-dlist flush-slate ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: run-line ( line y -- line ) swap tuck show-line step-capped-line ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: run-lines ( -- ) last-line> window-height [ run-line ] each >last-line ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: run-rule ( -- ) start-slate run-lines finish-slate ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: start-random ( -- ) random-line >last-line run-rule ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: start-center ( -- ) center-line >last-line run-rule ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
2006-06-18 06:04:54 -04:00
|
|
|
|
|
|
|
: random-item ( seq -- item ) dup length random-int swap nth ;
|
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
: interesting ( -- seq )
|
|
|
|
{ 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
|
|
|
|
110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
|
|
|
|
|
|
|
|
|
|
|
|
: mild ( -- seq )
|
|
|
|
{ 6 9 11 57 62 74 118 } ;
|
|
|
|
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-12 21:57:51 -04:00
|
|
|
! : automata ( -- )
|
|
|
|
! <slate> dup self set "Cellular Automata" open-titled-window
|
|
|
|
! init-rule interesting random-item set-rule 1000 sleep start-random ;
|
|
|
|
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
! automata-window
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
|
2006-07-26 14:40:19 -04:00
|
|
|
: [bind] ( ns quot -- quot ) \ bind 3array >quotation ;
|
|
|
|
|
2006-07-12 21:57:51 -04:00
|
|
|
: bind-button ( ns button -- )
|
|
|
|
tuck button-quot \ bind 3array >quotation swap set-button-quot ;
|
|
|
|
|
2006-07-26 14:40:19 -04:00
|
|
|
VARS: ns field frame ;
|
2006-07-12 21:57:51 -04:00
|
|
|
|
|
|
|
: init-slate ( -- ) <slate> t over set-gadget-clipped? self set ;
|
|
|
|
|
2006-07-26 14:40:19 -04:00
|
|
|
: init-field ( -- )
|
|
|
|
f ns> [ editor-text string>number set-rule start-center ] [bind] <field>
|
|
|
|
>field ;
|
2006-07-12 21:57:51 -04:00
|
|
|
|
2006-07-26 14:40:19 -04:00
|
|
|
: set-field-rule ( n -- ) number>string field> set-editor-text ;
|
2006-07-12 21:57:51 -04:00
|
|
|
|
|
|
|
: automata-window ( -- )
|
|
|
|
<frame> >frame
|
|
|
|
[ ] make-hash >ns
|
2006-07-26 14:40:19 -04:00
|
|
|
ns> [ init-rule init-slate init-field ] bind
|
|
|
|
ns> [ field> ] bind 1array
|
2006-07-12 21:57:51 -04:00
|
|
|
ns>
|
2006-07-26 14:40:19 -04:00
|
|
|
{ { "Center" [ start-center ] }
|
2006-07-12 21:57:51 -04:00
|
|
|
{ "Random" [ start-random ] }
|
|
|
|
{ "Continue" [ run-rule ] } }
|
|
|
|
[ first2 <bevel-button> tuck bind-button ]
|
|
|
|
map-with append make-pile 1 over set-pack-fill
|
|
|
|
frame> @left grid-add
|
|
|
|
ns> [ self get ] bind
|
|
|
|
frame> @center grid-add
|
|
|
|
frame> "Cellular Automata" open-titled-window
|
|
|
|
1000 sleep
|
2006-07-26 14:40:19 -04:00
|
|
|
ns> [ interesting random-item dup set-field-rule set-rule start-center ] bind ;
|
2006-06-18 06:04:54 -04:00
|
|
|
|
2006-07-07 02:46:14 -04:00
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
2006-06-18 21:31:20 -04:00
|
|
|
|
|
|
|
PROVIDE: automata ;
|