3 contrib/lindenmayer/opengl
6 USING: kernel namespaces math sequences arrays threads opengl gadgets
7 math-contrib vars opengl-contrib slate ;
11 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
15 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
21 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
25 VAR: separation-weight
27 VAR: cohesion-view-angle
28 VAR: alignment-view-angle
29 VAR: separation-view-angle
33 VAR: separation-radius
35 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
37 : init-variables ( -- )
40 1.0 >separation-weight
46 180 >cohesion-view-angle
47 180 >alignment-view-angle
48 180 >separation-view-angle
52 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
53 ! random-boid and random-boids
54 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
56 : random-range ( a b -- n ) 1 + dupd swap - random-int + ;
58 : random-pos ( -- pos ) world-size> [ random-int ] map ;
60 : random-vel ( -- vel ) 2 >array [ drop -10 10 random-range ] map ;
62 : random-boid ( -- boid ) random-pos random-vel <boid> ;
64 : random-boids ( n -- boids ) [ drop random-boid ] map ;
66 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
68 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
70 : boid-point-a ( boid -- a ) boid-pos ;
72 : boid-point-b ( boid -- b ) dup boid-pos swap boid-vel normalize 20 v*n v+ ;
74 : boid-points ( boid -- point-a point-b ) dup boid-point-a swap boid-point-b ;
76 : draw-line ( a b -- )
77 GL_LINES glBegin first2 glVertex2i first2 glVertex2i glEnd ;
79 : draw-boid ( boid -- ) boid-points draw-line ;
81 : draw-boids ( -- ) boids> [ draw-boid ] each ;
83 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
85 : distance ( boid boid -- n ) boid-pos swap boid-pos v- norm ;
87 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
89 : constrain ( n a b -- n ) rot min max ;
91 : angle-between ( vec vec -- angle )
92 2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
94 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
96 : relative-position ( self other -- v ) boid-pos swap boid-pos v- ;
98 : relative-angle ( self other -- angle )
99 over boid-vel -rot relative-position angle-between ;
101 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
103 : vsum ( vector-of-vectors --- vec ) { 0 0 } [ v+ ] reduce ;
105 : vaverage ( seq-of-vectors -- seq ) dup vsum swap length v/n ;
107 : average-position ( boids -- pos ) [ boid-pos ] map vaverage ;
109 : average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ;
111 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
113 : within-radius? ( self other radius -- ? ) >r distance r> <= ;
115 : within-view-angle? ( self other angle -- ? ) >r relative-angle r> 2 / <= ;
117 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
119 : within-cohesion-radius? ( self other -- ? )
120 cohesion-radius get within-radius? ;
122 : within-cohesion-view? ( self other -- ? )
123 cohesion-view-angle get within-view-angle? ;
125 : within-cohesion-neighborhood? ( self other -- ? )
127 [ within-cohesion-radius? ] 2keep
128 within-cohesion-view?
131 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
133 : within-separation-radius? ( self other -- ? )
134 separation-radius get within-radius? ;
136 : within-separation-view? ( self other -- ? )
137 separation-view-angle get within-view-angle? ;
139 : within-separation-neighborhood? ( self other -- ? )
141 [ within-separation-radius? ] 2keep
142 within-separation-view?
145 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
147 : within-alignment-radius? ( self other -- ? )
148 alignment-radius get within-radius? ;
150 : within-alignment-view? ( self other -- ? )
151 alignment-view-angle get within-view-angle? ;
153 : within-alignment-neighborhood? ( self other -- ? )
155 [ within-alignment-radius? ] 2keep
156 within-alignment-view?
159 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
161 : cohesion-neighborhood ( self -- boids )
162 boids> [ within-cohesion-neighborhood? ] subset-with ;
164 : cohesion-force ( self -- force )
165 dup cohesion-neighborhood
168 [ average-position swap boid-pos v- normalize cohesion-weight> v*n ]
171 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
173 : separation-neighborhood ( self -- boids )
174 boids> [ within-separation-neighborhood? ] subset-with ;
176 : separation-force ( self -- force )
177 dup separation-neighborhood
180 [ average-position swap boid-pos swap v- normalize separation-weight> v*n ]
183 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
185 : alignment-neighborhood ( self -- boids )
186 boids> [ within-alignment-neighborhood? ] subset-with ;
188 : alignment-force ( self -- force )
189 alignment-neighborhood
192 [ average-velocity normalize alignment-weight get v*n ]
195 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
199 ! We let m be equal to 1 so then this is simply: F = a
201 : acceleration ( boid -- acceleration )
205 cohesion-force v+ v+ ;
207 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
209 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
211 : world-width ( -- w ) world-size> first ;
213 : world-height ( -- w ) world-size> second ;
215 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
217 : below? ( n a b -- ? ) drop < ;
219 : above? ( n a b -- ? ) nip > ;
221 : wrap ( n a b -- n )
230 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
232 : wrap-x ( x -- x ) 0 world-width 1- wrap ;
234 : wrap-y ( y -- y ) 0 world-height 1- wrap ;
236 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
238 : new-pos ( boid -- pos ) dup boid-vel time-slice> v*n swap boid-pos v+ ;
240 : new-vel ( boid -- vel )
241 dup acceleration time-slice> v*n swap boid-vel v+ normalize ;
243 : wrap-pos ( pos -- pos ) first2 wrap-y swap wrap-x swap 2array ;
245 : iterate-boid ( self -- self ) dup >r new-pos wrap-pos r> new-vel <boid> ;
247 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
249 : iterate-boids ( -- ) boids> [ iterate-boid ] map >boids ;
251 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
253 : display ( -- ) GL_COLOR_BUFFER_BIT glClear black gl-color draw-boids ;
255 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
260 slate> rect-dim >world-size
261 iterate-boids .slate 1 sleep
262 stop? get [ ] [ run ] if ;
264 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
268 namespace slate> set-slate-ns
270 slate> "Boids" open-titled-window ;
272 : init-boids ( -- ) 50 random-boids >boids ;
274 : init-world-size ( -- ) { 100 100 } >world-size ;
276 : init ( -- ) init-slate init-variables init-world-size init-boids stop? off ;