contrib/boids.factor

   1 REQUIRES: contrib/math
   2           contrib/vars
   3           contrib/lindenmayer/opengl
   4           contrib/slate/slate ;
   5
   6 USING: kernel namespaces math sequences arrays threads opengl gadgets
   7        math-contrib vars opengl-contrib slate ;
   8
   9 IN: boids
  10
  11 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  12
  13 TUPLE: boid pos vel ;
  14
  15 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  16
  17 VAR: boids
  18 VAR: world-size
  19 VAR: time-slice
  20
  21 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  22
  23 VAR: cohesion-weight
  24 VAR: alignment-weight
  25 VAR: separation-weight
  26
  27 VAR: cohesion-view-angle
  28 VAR: alignment-view-angle
  29 VAR: separation-view-angle
  30
  31 VAR: cohesion-radius
  32 VAR: alignment-radius
  33 VAR: separation-radius
  34
  35 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  36
  37 : init-variables ( -- )
  38 1.0 >cohesion-weight
  39 1.0 >alignment-weight
  40 1.0 >separation-weight
  41
  42 75 >cohesion-radius
  43 50 >alignment-radius
  44 25 >separation-radius
  45
  46 180 >cohesion-view-angle
  47 180 >alignment-view-angle
  48 180 >separation-view-angle
  49
  50 10 >time-slice ;
  51
  52 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  53 ! random-boid and random-boids
  54 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  55
  56 : random-range ( a b -- n ) 1 + dupd swap - random-int + ;
  57
  58 : random-pos ( -- pos ) world-size> [ random-int ] map ;
  59
  60 : random-vel ( -- vel ) 2 >array [ drop -10 10 random-range ] map ;
  61
  62 : random-boid ( -- boid ) random-pos random-vel <boid> ;
  63
  64 : random-boids ( n -- boids ) [ drop random-boid ] map ;
  65
  66 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  67 ! draw-boid
  68 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  69
  70 : boid-point-a ( boid -- a ) boid-pos ;
  71
  72 : boid-point-b ( boid -- b ) dup boid-pos swap boid-vel normalize 20 v*n v+ ;
  73
  74 : boid-points ( boid -- point-a point-b ) dup boid-point-a swap boid-point-b ;
  75
  76 : draw-line ( a b -- )
  77 GL_LINES glBegin first2 glVertex2i first2 glVertex2i glEnd ;
  78
  79 : draw-boid ( boid -- ) boid-points draw-line ;
  80
  81 : draw-boids ( -- ) boids> [ draw-boid ] each ;
  82
  83 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  84
  85 : distance ( boid boid -- n ) boid-pos swap boid-pos v- norm ;
  86
  87 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  88
  89 : constrain ( n a b -- n ) rot min max ;
  90
  91 : angle-between ( vec vec -- angle )
  92 2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
  93
  94 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  95
  96 : relative-position ( self other -- v ) boid-pos swap boid-pos v- ;
  97
  98 : relative-angle ( self other -- angle )
  99 over boid-vel -rot relative-position angle-between ;
 100
 101 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 102
 103 : vsum ( vector-of-vectors --- vec ) { 0 0 } [ v+ ] reduce ;
 104
 105 : vaverage ( seq-of-vectors -- seq ) dup vsum swap length v/n ;
 106
 107 : average-position ( boids -- pos ) [ boid-pos ] map vaverage ;
 108
 109 : average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ;
 110
 111 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 112
 113 : within-radius? ( self other radius -- ? ) >r distance r> <= ;
 114
 115 : within-view-angle? ( self other angle -- ? ) >r relative-angle r> 2 / <= ;
 116
 117 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 118
 119 : within-cohesion-radius? ( self other -- ? )
 120   cohesion-radius get within-radius? ;
 121
 122 : within-cohesion-view? ( self other -- ? )
 123   cohesion-view-angle get within-view-angle? ;
 124
 125 : within-cohesion-neighborhood? ( self other -- ? )
 126   [ eq? not ] 2keep
 127   [ within-cohesion-radius? ] 2keep
 128   within-cohesion-view?
 129   and and ;
 130
 131 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 132
 133 : within-separation-radius? ( self other -- ? )
 134   separation-radius get within-radius? ;
 135
 136 : within-separation-view? ( self other -- ? )
 137   separation-view-angle get within-view-angle? ;
 138
 139 : within-separation-neighborhood? ( self other -- ? )
 140   [ eq? not ] 2keep
 141   [ within-separation-radius? ] 2keep
 142   within-separation-view?
 143   and and ;
 144
 145 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 146
 147 : within-alignment-radius? ( self other -- ? )
 148   alignment-radius get within-radius? ;
 149
 150 : within-alignment-view? ( self other -- ? )
 151   alignment-view-angle get within-view-angle? ;
 152
 153 : within-alignment-neighborhood? ( self other -- ? )
 154   [ eq? not ] 2keep
 155   [ within-alignment-radius? ] 2keep
 156   within-alignment-view?
 157   and and ;
 158
 159 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 160
 161 : cohesion-neighborhood ( self -- boids )
 162 boids> [ within-cohesion-neighborhood? ] subset-with ;
 163
 164 : cohesion-force ( self -- force )
 165 dup cohesion-neighborhood
 166 dup length 0 =
 167 [ 2drop { 0 0 } ]
 168 [ average-position swap boid-pos v- normalize cohesion-weight> v*n ]
 169 if ;
 170
 171 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 172
 173 : separation-neighborhood ( self -- boids )
 174 boids> [ within-separation-neighborhood? ] subset-with ;
 175
 176 : separation-force ( self -- force )
 177 dup separation-neighborhood
 178 dup length 0 =
 179 [ 2drop { 0 0 } ]
 180 [ average-position swap boid-pos swap v- normalize separation-weight> v*n ]
 181 if ;
 182
 183 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 184
 185 : alignment-neighborhood ( self -- boids )
 186 boids> [ within-alignment-neighborhood? ] subset-with ;
 187
 188 : alignment-force ( self -- force )
 189 alignment-neighborhood
 190 dup length 0 =
 191 [ drop { 0 0 } ]
 192 [ average-velocity normalize alignment-weight get v*n ]
 193 if ;
 194
 195 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 196
 197 ! F = m a
 198 !
 199 ! We let m be equal to 1 so then this is simply: F = a
 200
 201 : acceleration ( boid -- acceleration )
 202   dup dup
 203   separation-force rot
 204   alignment-force  rot
 205   cohesion-force v+ v+ ;
 206
 207 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 208 ! iterate-boid
 209 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 210
 211 : world-width ( -- w ) world-size> first ;
 212
 213 : world-height ( -- w ) world-size> second ;
 214
 215 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 216
 217 : below? ( n a b -- ? ) drop < ;
 218
 219 : above? ( n a b -- ? ) nip > ;
 220
 221 : wrap ( n a b -- n )
 222 { { [ 3dup below? ]
 223     [ 2nip ] }
 224   { [ 3dup above? ]
 225     [ drop nip ] }
 226   { [ t ]
 227     [ 2drop ] } }
 228 cond ;
 229
 230 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 231
 232 : wrap-x ( x -- x ) 0 world-width 1- wrap ;
 233
 234 : wrap-y ( y -- y ) 0 world-height 1- wrap ;
 235
 236 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 237
 238 : new-pos ( boid -- pos ) dup boid-vel time-slice> v*n swap boid-pos v+ ;
 239
 240 : new-vel ( boid -- vel )
 241 dup acceleration time-slice> v*n swap boid-vel v+ normalize ;
 242
 243 : wrap-pos ( pos -- pos ) first2 wrap-y swap wrap-x swap 2array ;
 244
 245 : iterate-boid ( self -- self ) dup >r new-pos wrap-pos r> new-vel <boid> ;
 246
 247 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 248
 249 : iterate-boids ( -- ) boids> [ iterate-boid ] map >boids ;
 250
 251 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 252
 253 : display ( -- ) GL_COLOR_BUFFER_BIT glClear black gl-color draw-boids ;
 254
 255 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 256
 257 VAR: stop?
 258
 259 : run ( -- )
 260 slate> rect-dim >world-size
 261 iterate-boids .slate 1 sleep
 262 stop? get [ ] [ run ] if ;
 263
 264 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 265
 266 : init-slate ( -- )
 267 <slate> >slate
 268 namespace slate> set-slate-ns
 269 [ display ] >action
 270 slate> "Boids" open-titled-window ;
 271
 272 : init-boids ( -- ) 50 random-boids >boids ;
 273
 274 : init-world-size ( -- ) { 100 100 } >world-size ;
 275
 276 : init ( -- ) init-slate init-variables init-world-size init-boids stop? off ;