1 ! Copyright (C) 2008 Eduardo Cavazos.
2 ! Copyright (C) 2011 Anton Gorenko.
3 ! See https://factorcode.org/license.txt for BSD license.
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 ;
13 QUALIFIED-WITH: models.range mr
16 TUPLE: boids-gadget < gadget paused boids behaviors dt ;
18 CONSTANT: initial-population 100
19 CONSTANT: initial-dt 5
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>
27 : <boids-gadget> ( -- gadget )
30 ${ WIDTH HEIGHT } >>pref-dim
31 initial-population random-boids >>boids
32 initial-behaviors >>behaviors
35 M: boids-gadget ungraft*
38 : vec>deg ( vec -- deg )
39 first2 rect> arg rad>deg ; inline
41 : draw-boid ( boid -- )
43 vel>> vec>deg 0 0 1 glRotated
51 : draw-boids ( boids -- )
52 0.0 0.0 0.0 0.5 glColor4f
55 M: boids-gadget draw-gadget* ( boids-gadget -- )
58 : iterate-system ( boids-gadget -- )
59 dup [ boids>> ] [ behaviors>> ] [ dt>> ] tri
60 simulate >>boids drop ;
62 :: start-boids-thread ( gadget -- )
72 TUPLE: range-observer quot ;
74 M: range-observer model-changed
75 [ range-value ] dip quot>> call( value -- ) ;
77 : connect ( range-model quot -- )
78 range-observer boa swap add-connection ;
80 :: behavior-panel ( behavior -- gadget )
81 2 3 <frame> white-interior { 2 4 } >>gap { 0 0 } >>filled-cell
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
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
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
98 { 5 5 } <border> white-interior
100 behavior class-of name>> COLOR: gray <framed-labeled-gadget> ;
102 :: set-population ( n boids-gadget -- )
104 dup length n - dup 0 >
106 [ neg random-boids append ] if
107 ] change-boids drop ;
110 : find-boids-gadget ( gadget -- boids-gadget )
111 dup boids-gadget? [ children>> [ boids-gadget? ] find nip ] unless ;
114 : com-pause ( boids-gadget -- )
116 dup paused>> not [ >>paused ] keep
117 [ drop ] [ start-boids-thread ] if ;
119 : com-randomize ( boids-gadget -- )
121 [ length random-boids ] change-boids relayout-1 ;
123 :: simulation-panel ( boids-gadget -- gadget )
124 <pile> white-interior
126 2 2 <frame> { 2 4 } >>gap { 0 0 } >>filled-cell
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
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
138 { 5 5 } <border> add-gadget
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
146 { 5 5 } <border> add-gadget
148 "simulation" COLOR: gray <framed-labeled-gadget> ;
150 TUPLE: boids-frame < pack ;
152 :: <boids-frame> ( -- boids-frame )
153 boids-frame new horizontal >>orientation
154 <boids-gadget> :> boids-gadget
155 boids-gadget [ start-boids-thread ] keep
158 <pile> { 5 5 } >>gap 1.0 >>fill
160 boids-gadget simulation-panel
163 boids-gadget behaviors>>
164 [ behavior-panel add-gadget ] each
166 { 5 5 } <border> add-gadget ;
168 boids-frame "touchbar" f {
173 MAIN-WINDOW: boids { { title "Boids" } }
174 <boids-frame> >>gadgets ;