steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Update automata ui to work with latest gadgets changes

darcs
wayo.cavazos 2006-07-26 18:40:19 +00:00
parent 491e10c55b
commit 97871e1807
1 changed files with 12 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
contrib/automata.factor
View File

@ -8,7 +8,7 @@ REQUIRES: math slate vars ;
USING: parser kernel hashtables namespaces sequences math io
math-contrib threads strings arrays prettyprint
gadgets gadgets-editors gadgets-frames gadgets-buttons gadgets-grids
gadgets gadgets-text gadgets-frames gadgets-buttons gadgets-grids
vars slate ;
IN: automata
@ -151,27 +151,28 @@ white set-clear-color black set-color clear-window ;
! automata-window
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [bind] ( ns quot -- quot ) \ bind 3array >quotation ;
: bind-button ( ns button -- )
tuck button-quot \ bind 3array >quotation swap set-button-quot ;
VARS: ns editor frame ;
VARS: ns field frame ;
: init-slate ( -- ) <slate> t over set-gadget-clipped? self set ;
: init-editor ( -- ) "" <editor> >editor ;
: init-field ( -- )
f ns> [ editor-text string>number set-rule start-center ] [bind] <field>
>field ;
: set-editor-rule ( n -- ) number>string editor> set-editor-text ;
: open-rule ( -- ) editor> editor-text string>number set-rule start-center ;
: set-field-rule ( n -- ) number>string field> set-editor-text ;
: automata-window ( -- )
<frame> >frame
[ ] make-hash >ns
ns> [ init-rule init-slate init-editor ] bind
ns> [ editor> ] bind 1array
ns> [ init-rule init-slate init-field ] bind
ns> [ field> ] bind 1array
ns>
{ { "Open" [ open-rule ] }
{ "Center" [ start-center ] }
{ { "Center" [ start-center ] }
{ "Random" [ start-random ] }
{ "Continue" [ run-rule ] } }
[ first2 <bevel-button> tuck bind-button ]
@ -181,7 +182,7 @@ ns> [ self get ] bind
frame> @center grid-add
frame> "Cellular Automata" open-titled-window
1000 sleep
ns> [ interesting random-item set-editor-rule open-rule ] bind ;
ns> [ interesting random-item dup set-field-rule set-rule start-center ] bind ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!