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 namespaces opengl opengl.demo-support opengl.gl
7 sequences threads ui ui.commands ui.gadgets ui.gadgets.borders
8 ui.gadgets.buttons ui.gadgets.frames ui.gadgets.grids
9 ui.gadgets.labeled ui.gadgets.labels ui.gadgets.packs
10 ui.gadgets.sliders ui.gadgets.tracks ui.gadgets.worlds ui.render
12 QUALIFIED-WITH: models.range mr
15 TUPLE: boids-gadget < gadget paused boids behaviours dt ;
17 CONSTANT: initial-population 100
18 CONSTANT: initial-dt 5
20 : initial-behaviours ( -- seq )
21 1.0 75 -0.1 <cohesion>
22 1.0 40 -0.5 <alignment>
23 1.0 25 -1.0 <separation>
26 : <boids-gadget> ( -- gadget )
29 ${ width height } >>pref-dim
30 initial-population random-boids >>boids
31 initial-behaviours >>behaviours
34 M: boids-gadget ungraft*
37 : vec>deg ( vec -- deg )
38 first2 rect> arg rad>deg ; inline
40 : draw-boid ( boid -- )
42 vel>> vec>deg 0 0 1 glRotated
50 : draw-boids ( boids -- )
51 0.0 0.0 0.0 0.5 glColor4f
54 M: boids-gadget draw-gadget* ( boids-gadget -- )
57 : iterate-system ( boids-gadget -- )
58 dup [ boids>> ] [ behaviours>> ] [ dt>> ] tri
59 simulate >>boids drop ;
61 :: start-boids-thread ( gadget -- )
71 TUPLE: range-observer quot ;
73 M: range-observer model-changed
74 [ range-value ] dip quot>> call( value -- ) ;
76 : connect ( range-model quot -- )
77 range-observer boa swap add-connection ;
79 :: behavior-panel ( behavior -- gadget )
80 2 3 <frame> white-interior { 2 4 } >>gap { 0 0 } >>filled-cell
82 "weight" <label> { 0 0 } grid-add
83 behavior weight>> 100 * >fixnum 0 0 200 1 mr:<range>
84 dup [ 100.0 / behavior weight<< ] connect
85 horizontal <slider> { 1 0 } grid-add
87 "radius" <label> { 0 1 } grid-add
88 behavior radius>> 0 0 100 1 mr:<range>
89 dup [ behavior radius<< ] connect
90 horizontal <slider> { 1 1 } grid-add
92 "angle" <label> { 0 2 } grid-add
93 behavior angle-cos>> acos rad>deg >fixnum 0 0 180 1 mr:<range>
94 dup [ deg>rad cos behavior angle-cos<< ] connect
95 horizontal <slider> { 1 2 } grid-add
97 { 5 5 } <border> white-interior
99 behavior class-of name>> COLOR: gray <framed-labeled-gadget> ;
101 :: set-population ( n boids-gadget -- )
103 dup length n - dup 0 >
105 [ neg random-boids append ] if
106 ] change-boids drop ;
108 : com-pause ( boids-gadget -- )
109 dup paused>> not [ >>paused ] keep
110 [ drop ] [ start-boids-thread ] if ;
112 : com-randomize ( boids-gadget -- )
113 [ length random-boids ] change-boids drop ;
115 :: simulation-panel ( boids-gadget -- gadget )
116 <pile> white-interior
118 2 2 <frame> { 2 4 } >>gap { 0 0 } >>filled-cell
120 "population" <label> { 0 0 } grid-add
121 initial-population 0 0 200 10 mr:<range>
122 dup [ boids-gadget set-population ] connect
123 horizontal <slider> { 1 0 } grid-add
125 "speed" <label> { 0 1 } grid-add
126 boids-gadget dt>> 0 1 10 1 mr:<range>
127 dup [ boids-gadget dt<< ] connect
128 horizontal <slider> { 1 1 } grid-add
130 { 5 5 } <border> add-gadget
132 <shelf> { 2 2 } >>gap
133 "pause" [ drop boids-gadget com-pause ]
134 <border-button> add-gadget
135 "randomize" [ drop boids-gadget com-randomize ]
136 <border-button> add-gadget
138 { 5 5 } <border> add-gadget
140 "simulation" COLOR: gray <framed-labeled-gadget> ;
142 :: create-gadgets ( -- gadgets )
143 <boids-gadget> :> boids-gadget
144 boids-gadget [ start-boids-thread ] keep
146 <pile> { 5 5 } >>gap 1.0 >>fill
148 boids-gadget simulation-panel
151 boids-gadget behaviours>>
152 [ behavior-panel add-gadget ] each
154 { 5 5 } <border> 2array ;
156 boids-gadget "touchbar" f {
161 MAIN-WINDOW: boids { { title "Boids" } }
163 horizontal >>orientation
164 create-gadgets >>gadgets ;