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 namespaces
6 opengl opengl.demo-support opengl.gl sequences threads ui
7 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 ui.render ;
10 QUALIFIED-WITH: models.range mr
13 TUPLE: boids-gadget < gadget paused boids behaviours dt ;
15 CONSTANT: initial-population 100
16 CONSTANT: initial-dt 5
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>
24 : <boids-gadget> ( -- gadget )
27 ${ width height } >>pref-dim
28 initial-population random-boids >>boids
29 initial-behaviours >>behaviours
32 M: boids-gadget ungraft*
35 : vec>deg ( vec -- deg )
36 first2 rect> arg rad>deg ; inline
38 : draw-boid ( boid -- )
40 vel>> vec>deg 0 0 1 glRotated
48 : draw-boids ( boids -- )
49 0.0 0.0 0.0 0.5 glColor4f
52 M:: boids-gadget draw-gadget* ( boids-gadget -- )
54 [ boids-gadget boids>> draw-boids ] with-translation ;
56 : iterate-system ( boids-gadget -- )
57 dup [ boids>> ] [ behaviours>> ] [ dt>> ] tri
58 simulate >>boids drop ;
60 :: start-boids-thread ( gadget -- )
70 TUPLE: range-observer quot ;
72 M: range-observer model-changed
73 [ range-value ] dip quot>> call( value -- ) ;
75 : connect ( range-model quot -- )
76 range-observer boa swap add-connection ;
78 :: behavior-panel ( behavior -- gadget )
79 2 3 <frame> { 2 4 } >>gap { 0 0 } >>filled-cell
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
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
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
96 behavior class name>> <labeled-gadget> ;
98 :: set-population ( n boids-gadget -- )
100 dup length n - dup 0 >
102 [ neg random-boids append ] if
103 ] change-boids drop ;
105 : pause-toggle ( boids-gadget -- )
106 dup paused>> not [ >>paused ] keep
107 [ drop ] [ start-boids-thread ] if ;
109 : randomize-boids ( boids-gadget -- )
110 [ length random-boids ] change-boids drop ;
112 :: simulation-panel ( boids-gadget -- gadget )
115 2 2 <frame> { 4 4 } >>gap { 0 0 } >>filled-cell
117 "polulation" <label> { 0 0 } grid-add
118 initial-population 0 0 200 10 mr:<range>
119 dup [ boids-gadget set-population ] connect
120 horizontal <slider> { 1 0 } grid-add
122 "speed" <label> { 0 1 } grid-add
123 boids-gadget dt>> 0 1 10 1 mr:<range>
124 dup [ boids-gadget dt<< ] connect
125 horizontal <slider> { 1 1 } grid-add
129 <shelf> { 2 2 } >>gap
130 "pause" [ drop boids-gadget pause-toggle ]
131 <border-button> add-gadget
132 "randomize" [ drop boids-gadget randomize-boids ]
133 <border-button> add-gadget
137 "simulation" <labeled-gadget> ;
139 :: create-gadgets ( -- gadgets )
141 <boids-gadget> :> boids-gadget
142 boids-gadget [ start-boids-thread ] keep
145 <pile> { 2 2 } >>gap 1.0 >>fill
147 boids-gadget simulation-panel
150 boids-gadget behaviours>>
151 [ behavior-panel add-gadget ] each
156 MAIN-WINDOW: boids { { title "Boids" } }