Added a user interface to boids

diff --git a/contrib/boids.factor b/contrib/boids.factor
index 677b71a017f7983a0d1b78aead41a073cb0436aa..2ceef57fa20af9a5130c2b3b6e78e30f7c20c244 100644 (file)
--- a/contrib/boids.factor
+++ b/contrib/boids.factor
@@ -1,34 +1,50 @@
 ! Eduardo Cavazos - wayo.cavazos@gmail.com
 
-! To run the demo do:  USE: boids boids-go
+! To run the demo do:
+! USE: boids
+! boids-window
+!
+! There are currently a few bugs. To work around them and to get better
+! results, increase the size of the window (larger than 400x400 is
+! good). Then press the "Reset" button to start the demo over.
 
 REQUIRES: slate ;
 
-USING: generic threads namespaces math kernel sequences arrays gadgets slate ;
+USING: generic threads namespaces math kernel sequences arrays gadgets
+       math-contrib slate vars ;
 
 IN: boids
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-SYMBOL: separation-radius   100 separation-radius set-global
-SYMBOL: alignment-radius    100 alignment-radius set-global
-SYMBOL: cohesion-radius     100 cohesion-radius set-global
+SYMBOL: separation-radius
+SYMBOL: alignment-radius
+SYMBOL: cohesion-radius
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SYMBOL: separation-view-angle
+SYMBOL: alignment-view-angle
+SYMBOL: cohesion-view-angle
 
-SYMBOL: separation-view-angle   90 separation-view-angle set-global
-SYMBOL: alignment-view-angle    90 alignment-view-angle set-global
-SYMBOL: cohesion-view-angle     90 cohesion-view-angle set-global
+SYMBOL: separation-weight
+SYMBOL: alignment-weight
+SYMBOL: cohesion-weight
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: init-variables ( -- )
+25 separation-radius set
+50 alignment-radius set
+75 cohesion-radius set
+
+180 separation-view-angle set
+180 alignment-view-angle set
+180 cohesion-view-angle set
 
-SYMBOL: separation-weight   1.0 separation-weight set-global
-SYMBOL: alignment-weight    0.5 alignment-weight set-global
-SYMBOL: cohesion-weight     1.0 cohesion-weight set-global
+1.0 separation-weight set
+1.0 alignment-weight set
+1.0 cohesion-weight set ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-SYMBOL: world-size   { 400 400 } world-size set-global
+SYMBOL: world-size
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -36,52 +52,35 @@ TUPLE: boid pos vel ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-SYMBOL: time-slice   0.5 time-slice set-global
+VAR: time-slice
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! random-boid and random-boids
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! : random-range dupd swap - random-int + ;
-
 : random-range ( a b -- n ) 1 + dupd swap - random-int + ;
 
-! : random-n ( n -- random-0-to-n-1 )
-!   1 - 0 swap random-int ;
-
 : random-pos ( -- pos ) world-size get [ random-int ] map ;
 
 : random-vel ( -- vel ) 2 >array [ drop -10 10 random-range ] map ;
 
 : random-boid ( -- boid ) random-pos random-vel <boid> ;
 
-: random-boids ( n -- boids ) >array [ drop random-boid ] map ;
+: random-boids ( n -- boids ) [ drop random-boid ] map ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 SYMBOL: boids
 
-DEFER: run-boids
-
-: boids-go ( -- )
-<slate> dup self set open-window
-100 capacity set
-50 random-boids boids set
-run-boids ;
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! draw-boid
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: boid-point-a ( boid -- point-a ) boid-pos ;
+: boid-point-a ( boid -- a ) boid-pos ;
 
-: boid-point-b ( boid -- point-b )
-  dup >r boid-pos
-  r> boid-vel normalize 20 v*n
-  v+ ;
+: boid-point-b ( boid -- b ) dup boid-pos swap boid-vel normalize 20 v*n v+ ;
 
-: boid-points ( boid -- point-a point-b )
-  dup >r boid-point-a r> boid-point-b ;
+: boid-points ( boid -- point-a point-b ) dup boid-point-a swap boid-point-b ;
 
 : draw-boid ( boid -- ) boid-points draw-line ;
 
@@ -91,34 +90,31 @@ run-boids ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: r->d ( radians -- degrees ) 180 * pi / ;
-
-: constrain ( n a b -- n ) >r max r> min ;
+: constrain ( n a b -- n ) rot min max ;
 
 : angle-between ( vec vec -- angle )
-  2dup >r >r
-  v.   r> norm r> norm *   /   -1 1 constrain acos r->d ;
+2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: relative-position ( self other -- v ) boid-pos swap boid-pos v- ;
+
 : relative-angle ( self other -- angle )
-  over >r >r
-  boid-vel   r> boid-pos r> boid-pos v-   angle-between ;
+over boid-vel -rot relative-position angle-between ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : vsum ( vector-of-vectors --- vec ) { 0 0 } [ v+ ] reduce ;
 
-: average-position ( boids -- pos )
-  [ boid-pos ] map   dup >r   vsum   r>   length   v/n ;
+: vaverage ( seq-of-vectors -- seq ) dup vsum swap length v/n ;
+
+: average-position ( boids -- pos ) [ boid-pos ] map vaverage ;
 
-: average-velocity ( boids -- vel )
-  [ boid-vel ] map   dup >r   vsum   r>   length   v/n ;
+: average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: subset-with ( obj seq quot -- seq | quot: obj elt -- elt )
-  [ >r dup r> ] swap append subset ;
+: subset-with ( obj seq quot -- seq ) [ dupd ] swap append subset ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -217,10 +213,6 @@ run-boids ;
 !
 ! We let m be equal to 1 so then this is simply: F = a
 
-! : acceleration ( boid -- acceleration )
-!  dup >r dup >r
-!  separation-force r> alignment-force r> cohesion-force v+ v+ ;
-
 : acceleration ( boid -- acceleration )
   dup dup
   separation-force rot
@@ -231,24 +223,58 @@ run-boids ;
 ! iterate-boid
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: new-pos ( boid -- pos )
-  dup >r   boid-pos   r> boid-vel time-slice get v*n   v+ ;
+: world-width ( -- w ) world-size get first ;
+
+: world-height ( -- w ) world-size get second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: below? ( n a b -- ? ) drop < ;
+
+: above? ( n a b -- ? ) nip > ;
+
+: wrap ( n a b -- n )
+{ { [ 3dup below? ]
+    [ 2nip ] }
+  { [ 3dup above? ]
+    [ drop nip ] }
+  { [ t ]
+    [ 2drop ] } }
+cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: wrap-x ( x -- x ) 0 world-width 1- wrap ;
+
+: wrap-y ( y -- y ) 0 world-height 1- wrap ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : new-pos ( boid -- pos )
+!   dup >r   boid-pos   r> boid-vel time-slice get v*n   v+ ;
 
 ! : new-vel ( boid -- vel )
 !   dup >r   boid-vel   r> acceleration time-slice get v*n   v+ ;
 
-: new-vel ( boid -- vel )
-  dup boid-vel swap acceleration time-slice get v*n   v+ ;
+! : new-vel ( boid -- vel )
+!   dup boid-vel swap acceleration time-slice get v*n   v+ ;
+
+! : wrap-x ( x -- x )
+!   dup   0 world-size get nth   >=   [ drop 0 ] when
+!   dup   0 < [ drop 0 world-size get nth   1 - ] when ;
+
+! : wrap-y ( y -- y )
+!   dup   1 world-size get nth   >=   [ drop 0 ] when
+!   dup   0 < [ drop 1 world-size get nth   1 - ] when ;
+
+: new-pos ( boid -- pos ) dup boid-vel time-slice> v*n swap boid-pos v+ ;
 
-: wrap-x ( x -- x )
-  dup   0 world-size get nth   >=   [ drop 0 ] when
-  dup   0 < [ drop 0 world-size get nth   1 - ] when ;
+! : new-vel ( boid -- vel ) dup acceleration time-slice> v*n swap boid-vel v+ ;
 
-: wrap-y ( y -- y )
-  dup   1 world-size get nth   >=   [ drop 0 ] when
-  dup   0 < [ drop 1 world-size get nth   1 - ] when ;
+: new-vel ( boid -- vel )
+dup acceleration time-slice> v*n swap boid-vel v+ normalize ;
 
-: wrap-pos ( pos -- pos ) [ ] each wrap-y swap wrap-x swap 2array ;
+: wrap-pos ( pos -- pos ) first2 wrap-y swap wrap-x swap 2array ;
 
 : iterate-boid ( self -- self ) dup >r new-pos wrap-pos r> new-vel <boid> ;
 
@@ -266,9 +292,103 @@ boids get [ draw-boid ] each   flush-dlist flush-slate ;
 
 ! : run-boids ( -- ) iterate-boids clear-window draw-boids 1 sleep run-boids ;
 
+SYMBOL: stop?
+
 : run-boids ( -- )
 self get rect-dim world-size set
-iterate-boids draw-boids 1 sleep run-boids ;
+iterate-boids draw-boids 1 sleep
+stop? get [ ] [ run-boids ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: boids-go ( -- )
+init-variables
+0.1 time-slice set
+! 1.0 >min-speed
+! 1.0 >max-speed
+<slate> dup self set open-window
+100 capacity set
+self get rect-dim world-size set
+50 random-boids boids set
+1000 sleep
+f stop? set
+run-boids ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Boids ui
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: gadgets-frames gadgets-labels gadgets-theme gadgets-grids
+       gadgets-editors gadgets-buttons ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [bind] ( ns quot -- quot ) \ bind 3array >quotation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VARS: ns frame ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: number-symbol-field ( label init symbol -- <field> )
+1array >quotation [ set ] append
+[ field-editor editor-text string>number ]
+swap append
+ns> swap [bind]
+<field> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-slate ( -- ) <slate> t over set-gadget-clipped? self set ;
+
+: boids-window ( -- )
+<frame> >frame
+[ ] make-hash >ns
+
+ns> [ init-slate
+      init-variables
+      10 time-slice set
+      100 capacity set
+      { 100 100 } world-size set
+      50 random-boids boids set
+      f stop? set
+] bind
+
+"Weight" <label> dup title-theme 1array
+"Alignment:  " "1" alignment-weight  number-symbol-field
+"Cohesion:   " "1" cohesion-weight   number-symbol-field
+"Separation: " "1" separation-weight number-symbol-field
+3array append
+
+"Radius" <label> dup title-theme 1array
+"Alignment:  " "50" alignment-radius  number-symbol-field
+"Cohesion:   " "75" cohesion-radius   number-symbol-field
+"Separation: " "25" separation-radius number-symbol-field
+3array append
+
+"View angle" <label> dup title-theme 1array
+"Alignment:  " "180" alignment-view-angle  number-symbol-field
+"Cohesion:   " "180" cohesion-view-angle   number-symbol-field
+"Separation: " "180" separation-view-angle number-symbol-field
+3array append
+
+"" <label> dup title-theme 1array
+
+"Time slice: " "10" time-slice number-symbol-field 1array
+
+"Stop" ns> [ t stop? set ] [bind] <bevel-button>
+"Start" ns> [ f stop? set [ run-boids ] in-thread ] [bind] <bevel-button>
+"Reset" ns> [ 50 random-boids boids set ] [bind] <bevel-button>
+3array
+
+append append append append append
+make-pile 1 over set-pack-fill frame> @left grid-add
+
+ns> [ self get ] bind frame> @center grid-add
+frame> "Boids" open-titled-window
+ns> [ 1000 sleep [ run-boids ] in-thread ] bind
+;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! Comments from others: