extra/boids/boids.factor

   1 ! Copyright (C) 2008 Eduardo Cavazos.
   2 ! Copyright (C) 2011 Anton Gorenko.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors arrays boids.simulation calendar classes
   5 colors.constants kernel literals locals math math.functions
   6 math.trig models opengl opengl.demo-support opengl.gl sequences
   7 threads ui ui.gadgets ui.gadgets.borders ui.gadgets.buttons
   8 ui.gadgets.frames ui.gadgets.grids ui.gadgets.labeled
   9 ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders
  10 ui.gadgets.tracks ui.render ui.tools.common ;
  11 QUALIFIED-WITH: models.range mr
  12 IN: boids
  13
  14 TUPLE: boids-gadget < gadget paused boids behaviours dt ;
  15
  16 CONSTANT: initial-population 100
  17 CONSTANT: initial-dt 5
  18
  19 : initial-behaviours ( -- seq )
  20     1.0 75 -0.1 <cohesion>
  21     1.0 40 -0.5 <alignment>
  22     1.0 25 -1.0 <separation>
  23     3array ;
  24
  25 : <boids-gadget> ( -- gadget )
  26     boids-gadget new
  27         t >>clipped?
  28         ${ width height } >>pref-dim
  29         initial-population random-boids >>boids
  30         initial-behaviours >>behaviours
  31         initial-dt >>dt ;
  32
  33 M:  boids-gadget ungraft*
  34     t >>paused drop ;
  35
  36 : vec>deg ( vec -- deg )
  37     first2 rect> arg rad>deg ; inline
  38
  39 : draw-boid ( boid -- )
  40     dup pos>> [
  41         vel>> vec>deg 0 0 1 glRotated
  42         GL_TRIANGLES [
  43             -6.0  4.0 glVertex2f
  44             -6.0 -4.0 glVertex2f
  45             8.0 0.0 glVertex2f
  46          ] do-state
  47     ] with-translation ;
  48
  49 : draw-boids ( boids -- )
  50     0.0 0.0 0.0 0.5 glColor4f
  51     [ draw-boid ] each ;
  52
  53 M: boids-gadget draw-gadget* ( boids-gadget -- )
  54     boids>> draw-boids ;
  55
  56 : iterate-system ( boids-gadget -- )
  57     dup [ boids>> ] [ behaviours>> ] [ dt>> ] tri
  58     simulate >>boids drop ;
  59
  60 :: start-boids-thread ( gadget -- )
  61     [
  62         [ gadget paused>> ]
  63         [
  64             gadget iterate-system
  65             gadget relayout-1
  66             10 milliseconds sleep
  67         ] until
  68     ] in-thread ;
  69
  70 TUPLE: range-observer quot ;
  71
  72 M: range-observer model-changed
  73     [ range-value ] dip quot>> call( value -- ) ;
  74
  75 : connect ( range-model quot -- )
  76     range-observer boa swap add-connection ;
  77
  78 :: behavior-panel ( behavior -- gadget )
  79     2 3 <frame> white-interior { 2 4 } >>gap { 0 0 } >>filled-cell
  80
  81     "weight" <label> { 0 0 } grid-add
  82     behavior weight>> 100 * >fixnum 0 0 200 1 mr:<range>
  83     dup [ 100.0 / behavior weight<< ] connect
  84     horizontal <slider> { 1 0 } grid-add
  85
  86     "radius" <label> { 0 1 } grid-add
  87     behavior radius>> 0 0 100 1 mr:<range>
  88     dup [ behavior radius<< ] connect
  89     horizontal <slider> { 1 1 } grid-add
  90
  91     "angle" <label> { 0 2 } grid-add
  92     behavior angle-cos>> acos rad>deg >fixnum 0 0 180 1 mr:<range>
  93     dup [ deg>rad cos behavior angle-cos<< ] connect
  94     horizontal <slider> { 1 2 } grid-add
  95
  96     { 5 5 } <border> white-interior
  97
  98     behavior class-of name>> COLOR: gray <framed-labeled-gadget> ;
  99
 100 :: set-population ( n boids-gadget -- )
 101     boids-gadget [
 102         dup length n - dup 0 >
 103         [ head* ]
 104         [ neg random-boids append ] if
 105     ] change-boids drop ;
 106
 107 : pause-toggle ( boids-gadget -- )
 108     dup paused>> not [ >>paused ] keep
 109     [ drop ] [ start-boids-thread ] if ;
 110
 111 : randomize-boids ( boids-gadget -- )
 112     [ length random-boids ] change-boids drop ;
 113
 114 :: simulation-panel ( boids-gadget -- gadget )
 115     <pile> white-interior
 116
 117     2 2 <frame> { 2 4 } >>gap { 0 0 } >>filled-cell
 118
 119     "population" <label> { 0 0 } grid-add
 120     initial-population 0 0 200 10 mr:<range>
 121     dup [ boids-gadget set-population ] connect
 122     horizontal <slider> { 1 0 } grid-add
 123
 124     "speed" <label> { 0 1 } grid-add
 125     boids-gadget dt>> 0 1 10 1 mr:<range>
 126     dup [ boids-gadget dt<< ] connect
 127     horizontal <slider> { 1 1 } grid-add
 128
 129     { 5 5 } <border> add-gadget
 130
 131     <shelf> { 2 2 } >>gap
 132     "pause" [ drop boids-gadget pause-toggle ]
 133     <border-button> add-gadget
 134     "randomize" [ drop boids-gadget randomize-boids ]
 135     <border-button> add-gadget
 136
 137     { 5 5 } <border> add-gadget
 138
 139     "simulation" COLOR: gray <framed-labeled-gadget> ;
 140
 141 :: create-gadgets ( -- gadgets )
 142     <shelf>
 143     <boids-gadget> :> boids-gadget
 144     boids-gadget [ start-boids-thread ] keep
 145     add-gadget
 146
 147     <pile> { 5 5 } >>gap 1.0 >>fill
 148
 149     boids-gadget simulation-panel
 150     add-gadget
 151
 152     boids-gadget behaviours>>
 153     [ behavior-panel add-gadget ] each
 154
 155     { 5 5 } <border> add-gadget ;
 156
 157 MAIN-WINDOW: boids { { title "Boids" } }
 158     create-gadgets
 159     >>gadgets ;