28 combinators.short-circuit
32 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
36 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
38 : constrain ( n a b -- n ) rot min max ;
40 : angle-between ( vec vec -- angle )
41 [ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ;
43 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
45 : relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
47 : relative-angle ( self other -- angle )
48 over vel>> -rot relative-position angle-between ;
50 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
52 : in-radius? ( self other radius -- ? ) [ distance ] dip <= ;
53 : in-view? ( self other angle -- ? ) [ relative-angle ] dip 2 / <= ;
55 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
57 : vsum ( vector-of-vectors -- vec ) { 0 0 } [ v+ ] reduce ;
59 : vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
61 : average-position ( boids -- pos ) [ pos>> ] map vaverage ;
62 : average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
64 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
66 TUPLE: <boid> < <vel> ;
68 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
71 { weight initial: 1.0 }
72 { view-angle initial: 180 }
75 TUPLE: <cohesion> < <behaviour> { radius initial: 75 } ;
76 TUPLE: <alignment> < <behaviour> { radius initial: 50 } ;
77 TUPLE: <separation> < <behaviour> { radius initial: 25 } ;
79 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
81 :: within-neighborhood? ( SELF OTHER BEHAVIOUR -- ? )
85 [ BEHAVIOUR radius>> in-radius? ]
86 [ BEHAVIOUR view-angle>> in-view? ]
91 :: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
92 OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
94 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
96 : normalize* ( u -- v ) { 0.001 0.001 } v+ normalize ;
98 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
100 GENERIC: force* ( sequence <boid> <behaviour> -- force )
102 :: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
103 OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
105 :: alignment-force ( OTHERS SELF BEHAVIOUR -- force )
106 OTHERS average-velocity normalize* BEHAVIOUR weight>> v*n ;
108 :: separation-force ( OTHERS SELF BEHAVIOUR -- force )
109 SELF pos>> OTHERS average-position v- normalize* BEHAVIOUR weight>> v*n ;
111 METHOD: force* ( sequence <boid> <cohesion> -- force ) cohesion-force ;
112 METHOD: force* ( sequence <boid> <alignment> -- force ) alignment-force ;
113 METHOD: force* ( sequence <boid> <separation> -- force ) separation-force ;
115 :: force ( OTHERS SELF BEHAVIOUR -- force )
116 SELF OTHERS BEHAVIOUR neighborhood
118 [ SELF BEHAVIOUR force* ]
121 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
123 : random-boids ( count -- boids )
127 2 [ drop 1000 random ] map >>pos
128 2 [ drop -10 10 [a,b] random ] map >>vel
132 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
134 : draw-boid ( boid -- )
136 dup pos>> gl-translate-2d
137 vel>> first2 rect> arg rad>deg 0 0 1 glRotated
138 { { 0 5 } { 0 -5 } { 20 0 } } triangle
142 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
144 : gadget->sky ( gadget -- sky ) { 0 0 } swap dim>> <rectangle> boa ;
146 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
148 USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
150 TUPLE: <boids-gadget> < gadget paused boids behaviours time-slice ;
152 M: <boids-gadget> pref-dim* ( <boids-gadget> -- dim ) drop { 600 400 } ;
153 M: <boids-gadget> ungraft* ( <boids-gadget> -- ) t >>paused drop ;
155 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
157 :: iterate-system ( BOIDS-GADGET -- )
159 [let | SKY [ BOIDS-GADGET gadget->sky ]
160 BOIDS [ BOIDS-GADGET boids>> ]
161 TIME-SLICE [ BOIDS-GADGET time-slice>> ]
162 BEHAVIOURS [ BOIDS-GADGET behaviours>> ] |
168 [wlet | force-due-to [| BEHAVIOUR | BOIDS SELF BEHAVIOUR force ] |
170 ! F = m a. M is 1. So F = a.
172 [let | ACCEL [ BEHAVIOURS [ force-due-to ] map vsum ] |
174 [let | POS [ SELF pos>> SELF vel>> TIME-SLICE v*n v+ ]
175 VEL [ SELF vel>> ACCEL TIME-SLICE v*n v+ ] |
177 [let | POS [ POS SKY wrap ]
178 VEL [ VEL normalize* ] |
180 T{ <boid> f POS VEL } ] ] ] ]
186 BOIDS-GADGET (>>boids) ] ;
188 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
190 M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
192 [ BOIDS-GADGET boids>> [ draw-boid ] each ]
195 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
197 :: start-boids-thread ( GADGET -- )
198 GADGET f >>paused drop
203 [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
210 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
212 : default-behaviours ( -- seq )
213 { <cohesion> <alignment> <separation> } [ new ] map ;
215 : boids-gadget ( -- gadget )
216 <boids-gadget> new-gadget
217 100 random-boids >>boids
218 default-behaviours >>behaviours
222 : run-boids ( -- ) boids-gadget dup "Boids" open-window start-boids-thread ;
224 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
231 : truncate-number ( n -- n ) 10 * round 10 / ;
233 :: make-behaviour-control ( NAME BEHAVIOUR -- gadget )
234 [let | NAME-LABEL [ NAME <label> reverse-video-theme ]
235 VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
237 [wlet | update-value-label [ ! ( -- )
238 BEHAVIOUR weight>> truncate-number number>string
246 NAME-LABEL 0.5 track-add
247 VALUE-LABEL 0.5 track-add
253 BEHAVIOUR [ 0.1 + ] change-weight drop
256 <bevel-button> add-gadget
261 BEHAVIOUR weight>> 0.1 >
263 BEHAVIOUR [ 0.1 - ] change-weight drop
268 <bevel-button> add-gadget ] ] ;
270 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
272 :: make-population-control ( BOIDS-GADGET -- gadget )
273 [let | VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
275 [wlet | update-value-label [ ( -- )
276 BOIDS-GADGET boids>> length number>string
285 "Population: " <label> reverse-video-theme 0.5 track-add
286 VALUE-LABEL 0.5 track-add
293 BOIDS-GADGET boids>> 10 random-boids append
304 BOIDS-GADGET boids>> length 10 >
307 BOIDS-GADGET boids>> 10 tail
315 add-gadget ] ] ( gadget -- gadget ) ;
317 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
319 :: pause-toggle ( BOIDS-GADGET -- )
320 BOIDS-GADGET paused>>
321 [ BOIDS-GADGET start-boids-thread ]
322 [ BOIDS-GADGET t >>paused drop ]
325 :: randomize-boids ( BOIDS-GADGET -- )
326 BOIDS-GADGET BOIDS-GADGET boids>> length random-boids >>boids drop ;
330 [let | BOIDS-GADGET [ boids-gadget ] |
338 "Pause" [ drop BOIDS-GADGET pause-toggle ] <bevel-button> add-gadget
341 [ drop BOIDS-GADGET randomize-boids ] <bevel-button> add-gadget
343 BOIDS-GADGET make-population-control add-gadget
345 "Cohesion: " BOIDS-GADGET behaviours>> first make-behaviour-control
346 "Alignment: " BOIDS-GADGET behaviours>> second make-behaviour-control
347 "Separation: " BOIDS-GADGET behaviours>> third make-behaviour-control
353 BOIDS-GADGET @center grid-add
357 BOIDS-GADGET start-boids-thread ] ;
359 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
361 : boids-main ( -- ) [ boids-app ] with-ui ;