extra/boids/boids.factor

   1
   2 USING: kernel
   3        namespaces
   4        arrays
   5        accessors
   6        strings
   7        sequences
   8        locals
   9        threads
  10        math
  11        math.functions
  12        math.trig
  13        math.order
  14        math.ranges
  15        math.vectors
  16        random
  17        calendar
  18        opengl.gl
  19        opengl
  20        ui
  21        ui.gadgets
  22        ui.gadgets.tracks
  23        ui.gadgets.frames
  24        ui.gadgets.grids
  25        ui.render
  26        multi-methods
  27        multi-method-syntax
  28        combinators.short-circuit
  29        processing.shapes
  30        flatland ;
  31
  32 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  33
  34 IN: boids
  35
  36 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  37
  38 : constrain ( n a b -- n ) rot min max ;
  39
  40 : angle-between ( vec vec -- angle )
  41   [ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ;
  42
  43 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  44
  45 : relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
  46
  47 : relative-angle ( self other -- angle )
  48   over vel>> -rot relative-position angle-between ;
  49
  50 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  51
  52 : in-radius? ( self other radius -- ? ) [ distance       ] dip     <= ;
  53 : in-view?   ( self other angle  -- ? ) [ relative-angle ] dip 2 / <= ;
  54
  55 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  56
  57 : vsum ( vector-of-vectors -- vec ) { 0 0 } [ v+ ] reduce ;
  58
  59 : vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
  60
  61 : average-position ( boids -- pos ) [ pos>> ] map vaverage ;
  62 : average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
  63
  64 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  65
  66 TUPLE: <boid> < <vel> ;
  67
  68 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  69
  70 TUPLE: <behaviour>
  71   { weight     initial: 1.0 }
  72   { view-angle initial: 180 }
  73   { radius                  } ;
  74
  75 TUPLE: <cohesion>   < <behaviour> { radius initial: 75 } ;
  76 TUPLE: <alignment>  < <behaviour> { radius initial: 50 } ;
  77 TUPLE: <separation> < <behaviour> { radius initial: 25 } ;
  78
  79 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  80
  81 :: within-neighborhood? ( SELF OTHER BEHAVIOUR -- ? )
  82
  83   SELF OTHER
  84     {
  85       [ BEHAVIOUR radius>>     in-radius? ]
  86       [ BEHAVIOUR view-angle>> in-view?   ]
  87       [ eq? not                           ]
  88     }
  89   2&& ;
  90
  91 :: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
  92   OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
  93
  94 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  95
  96 : normalize* ( u -- v ) { 0.001 0.001 } v+ normalize ;
  97
  98 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  99
 100 GENERIC: force* ( sequence <boid> <behaviour> -- force )
 101
 102 :: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
 103   OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
 104
 105 :: alignment-force ( OTHERS SELF BEHAVIOUR -- force )
 106   OTHERS average-velocity normalize* BEHAVIOUR weight>> v*n ;
 107
 108 :: separation-force ( OTHERS SELF BEHAVIOUR -- force )
 109   SELF pos>> OTHERS average-position v- normalize* BEHAVIOUR weight>> v*n ;
 110
 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 ;
 114
 115 :: force ( OTHERS SELF BEHAVIOUR -- force )
 116   SELF OTHERS BEHAVIOUR neighborhood
 117     [ { 0 0 } ]
 118     [ SELF BEHAVIOUR force* ]
 119   if-empty ;
 120
 121 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 122
 123 : random-boids ( count -- boids )
 124   [
 125     drop
 126     <boid> new
 127       2 [ drop         1000 random ] map >>pos
 128       2 [ drop -10 10 [a,b] random ] map >>vel
 129   ]
 130   map ;
 131
 132 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 133
 134 : draw-boid ( boid -- )
 135   glPushMatrix
 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
 139     fill-mode
 140   glPopMatrix ;
 141
 142 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 143
 144 : gadget->sky ( gadget -- sky ) { 0 0 } swap dim>> <rectangle> boa ;
 145
 146 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 147
 148 USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
 149
 150 TUPLE: <boids-gadget> < gadget paused boids behaviours time-slice ;
 151
 152 M:  <boids-gadget> pref-dim*    ( <boids-gadget> -- dim ) drop { 600 400 } ;
 153 M:  <boids-gadget> ungraft*     ( <boids-gadget> --     ) t >>paused drop  ;
 154
 155 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 156
 157 :: iterate-system ( BOIDS-GADGET -- )
 158
 159   [let | SKY        [ BOIDS-GADGET gadget->sky   ]
 160          BOIDS      [ BOIDS-GADGET boids>>       ]
 161          TIME-SLICE [ BOIDS-GADGET time-slice>>  ]
 162          BEHAVIOURS [ BOIDS-GADGET behaviours>>  ] |
 163
 164     BOIDS
 165
 166       [| SELF |
 167
 168         [wlet | force-due-to [| BEHAVIOUR | BOIDS SELF BEHAVIOUR force ] |
 169
 170           ! F = m a. M is 1. So F = a.
 171
 172           [let | ACCEL [ BEHAVIOURS [ force-due-to ] map vsum ] |
 173
 174             [let | POS [ SELF pos>> SELF vel>> TIME-SLICE v*n v+ ]
 175                    VEL [ SELF vel>> ACCEL      TIME-SLICE v*n v+ ] |
 176
 177               [let | POS [ POS SKY wrap   ]
 178                      VEL [ VEL normalize* ] |
 179
 180                 T{ <boid> f POS VEL } ] ] ] ]
 181
 182       ]
 183
 184     map
 185
 186     BOIDS-GADGET (>>boids) ] ;
 187
 188 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 189
 190 M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
 191   origin get
 192     [ BOIDS-GADGET boids>> [ draw-boid ] each ]
 193   with-translation ;
 194
 195 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 196
 197 :: start-boids-thread ( GADGET -- )
 198   GADGET f >>paused drop
 199   [
 200     [
 201       GADGET paused>>
 202         [ f ]
 203         [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
 204       if
 205     ]
 206     loop
 207   ]
 208   in-thread ;
 209
 210 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 211
 212 : default-behaviours ( -- seq )
 213   { <cohesion> <alignment> <separation> } [ new ] map ;
 214
 215 : boids-gadget ( -- gadget )
 216   <boids-gadget> new-gadget
 217     100 random-boids   >>boids
 218     default-behaviours >>behaviours
 219     10                 >>time-slice
 220     t                  >>clipped? ;
 221
 222 : run-boids ( -- ) boids-gadget dup "Boids" open-window start-boids-thread ;
 223
 224 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 225
 226 USING: math.parser
 227        ui.gadgets.labels
 228        ui.gadgets.buttons
 229        ui.gadgets.packs ;
 230
 231 : truncate-number ( n -- n ) 10 * round 10 / ;
 232
 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 ] |
 236
 237     [wlet | update-value-label [ ! ( -- )
 238               BEHAVIOUR weight>> truncate-number number>string
 239               VALUE-LABEL
 240               (>>string) ] |
 241
 242       update-value-label
 243
 244     <pile> 1 >>fill
 245       { 1 0 } <track>
 246         NAME-LABEL  0.5 track-add
 247         VALUE-LABEL 0.5 track-add
 248       add-gadget
 249
 250       "+0.1"
 251       [
 252         drop
 253         BEHAVIOUR [ 0.1 + ] change-weight drop
 254         update-value-label
 255       ]
 256       <bevel-button> add-gadget
 257
 258       "-0.1"
 259       [
 260         drop
 261         BEHAVIOUR weight>> 0.1 >
 262         [
 263           BEHAVIOUR [ 0.1 - ] change-weight drop
 264           update-value-label
 265         ]
 266         when
 267       ]
 268       <bevel-button> add-gadget ] ] ;
 269
 270 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 271
 272 :: make-population-control ( BOIDS-GADGET -- gadget )
 273   [let | VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
 274
 275     [wlet | update-value-label [ ( -- )
 276               BOIDS-GADGET boids>> length number>string
 277               VALUE-LABEL
 278               (>>string) ] |
 279
 280       update-value-label
 281
 282       <pile> 1 >>fill
 283
 284         { 1 0 } <track>
 285           "Population: " <label> reverse-video-theme 0.5 track-add
 286           VALUE-LABEL                                0.5 track-add
 287         add-gadget
 288
 289         "Add 10"
 290         [
 291           drop
 292           BOIDS-GADGET
 293             BOIDS-GADGET boids>> 10 random-boids append
 294           >>boids
 295           drop
 296           update-value-label
 297         ]
 298         <bevel-button>
 299         add-gadget
 300
 301         "Sub 10"
 302         [
 303           drop
 304           BOIDS-GADGET boids>> length 10 >
 305           [
 306             BOIDS-GADGET
 307               BOIDS-GADGET boids>> 10 tail
 308             >>boids
 309             drop
 310             update-value-label
 311           ]
 312           when
 313         ]
 314         <bevel-button>
 315         add-gadget ] ] ( gadget -- gadget ) ;
 316
 317 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 318
 319 :: pause-toggle ( BOIDS-GADGET -- )
 320   BOIDS-GADGET paused>>
 321     [ BOIDS-GADGET start-boids-thread ]
 322     [ BOIDS-GADGET t >>paused drop    ]
 323   if ;
 324
 325 :: randomize-boids ( BOIDS-GADGET -- )
 326   BOIDS-GADGET   BOIDS-GADGET boids>> length random-boids   >>boids drop ;
 327
 328 : boids-app ( -- )
 329
 330   [let | BOIDS-GADGET [ boids-gadget ] |
 331
 332     <frame>
 333
 334       <shelf>
 335
 336         1 >>fill
 337
 338         "Pause" [ drop BOIDS-GADGET pause-toggle ] <bevel-button> add-gadget
 339
 340         "Randomize"
 341         [ drop BOIDS-GADGET randomize-boids ] <bevel-button> add-gadget
 342
 343         BOIDS-GADGET make-population-control add-gadget
 344
 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
 348
 349         [ add-gadget ] tri@
 350
 351       @top grid-add
 352
 353       BOIDS-GADGET @center grid-add
 354
 355     "Boids" open-window
 356
 357     BOIDS-GADGET start-boids-thread ] ;
 358
 359 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 360
 361 : boids-main ( -- ) [ boids-app ] with-ui ;
 362
 363 MAIN: boids-main