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