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