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