fix 'boids' and move it from unmantained to extra;
Anton Gorenko
parent
43e4cf8754
commit
588af74590
|
|
@ -1 +1,2 @@
|
|||
Eduardo Cavazos
|
||||
Anton Gorenko
|
||||
|
|
@ -0,0 +1,159 @@
|
|||
! Copyright (C) 2008 Eduardo Cavazos.
|
||||
! Copyright (C) 2011 Anton Gorenko.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays boids.simulation calendar classes kernel
|
||||
literals locals math math.functions math.trig models namespaces
|
||||
opengl opengl.demo-support opengl.gl sequences threads ui
|
||||
ui.gadgets ui.gadgets.borders ui.gadgets.buttons
|
||||
ui.gadgets.frames ui.gadgets.grids ui.gadgets.labeled
|
||||
ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders ui.render ;
|
||||
QUALIFIED-WITH: models.range mr
|
||||
IN: boids
|
||||
|
||||
TUPLE: boids-gadget < gadget paused boids behaviours dt ;
|
||||
|
||||
CONSTANT: initial-population 100
|
||||
CONSTANT: initial-dt 5
|
||||
|
||||
: initial-behaviours ( -- seq )
|
||||
1.0 75 -0.1 <cohesion>
|
||||
1.0 40 -0.5 <alignment>
|
||||
1.0 25 -1.0 <separation>
|
||||
3array ;
|
||||
|
||||
: <boids-gadget> ( -- gadget )
|
||||
boids-gadget new
|
||||
t >>clipped?
|
||||
${ width height } >>pref-dim
|
||||
initial-population random-boids >>boids
|
||||
initial-behaviours >>behaviours
|
||||
initial-dt >>dt ;
|
||||
|
||||
M: boids-gadget ungraft*
|
||||
t >>paused drop ;
|
||||
|
||||
: vec>deg ( vec -- deg )
|
||||
first2 rect> arg rad>deg ; inline
|
||||
|
||||
: draw-boid ( boid -- )
|
||||
dup pos>> [
|
||||
vel>> vec>deg 0 0 1 glRotated
|
||||
GL_TRIANGLES [
|
||||
-6.0 4.0 glVertex2f
|
||||
-6.0 -4.0 glVertex2f
|
||||
8.0 0.0 glVertex2f
|
||||
] do-state
|
||||
] with-translation ;
|
||||
|
||||
: draw-boids ( boids -- )
|
||||
0.0 0.0 0.0 0.5 glColor4f
|
||||
[ draw-boid ] each ;
|
||||
|
||||
M:: boids-gadget draw-gadget* ( boids-gadget -- )
|
||||
origin get
|
||||
[ boids-gadget boids>> draw-boids ] with-translation ;
|
||||
|
||||
: iterate-system ( boids-gadget -- )
|
||||
dup [ boids>> ] [ behaviours>> ] [ dt>> ] tri
|
||||
simulate >>boids drop ;
|
||||
|
||||
:: start-boids-thread ( gadget -- )
|
||||
[
|
||||
[ gadget paused>> ]
|
||||
[
|
||||
gadget iterate-system
|
||||
gadget relayout-1
|
||||
10 milliseconds sleep
|
||||
] until
|
||||
] in-thread ;
|
||||
|
||||
TUPLE: range-observer quot ;
|
||||
|
||||
M: range-observer model-changed
|
||||
[ range-value ] dip quot>> call( value -- ) ;
|
||||
|
||||
: connect ( range-model quot -- )
|
||||
range-observer boa swap add-connection ;
|
||||
|
||||
:: behavior-panel ( behavior -- gadget )
|
||||
2 3 <frame> { 2 4 } >>gap { 0 0 } >>filled-cell
|
||||
|
||||
"weight" <label> { 0 0 } grid-add
|
||||
behavior weight>> 100 * >fixnum 0 0 200 1 mr:<range>
|
||||
dup [ 100.0 / behavior weight<< ] connect
|
||||
horizontal <slider> { 1 0 } grid-add
|
||||
|
||||
"radius" <label> { 0 1 } grid-add
|
||||
behavior radius>> 0 0 100 1 mr:<range>
|
||||
dup [ behavior radius<< ] connect
|
||||
horizontal <slider> { 1 1 } grid-add
|
||||
|
||||
"angle" <label> { 0 2 } grid-add
|
||||
behavior angle-cos>> acos rad>deg >fixnum 0 0 180 1 mr:<range>
|
||||
dup [ deg>rad cos behavior angle-cos<< ] connect
|
||||
horizontal <slider> { 1 2 } grid-add
|
||||
|
||||
behavior class name>> <labeled-gadget> ;
|
||||
|
||||
:: set-population ( n boids-gadget -- )
|
||||
boids-gadget [
|
||||
dup length n - dup 0 >
|
||||
[ head* ]
|
||||
[ neg random-boids append ] if
|
||||
] change-boids drop ;
|
||||
|
||||
: pause-toggle ( boids-gadget -- )
|
||||
dup paused>> not [ >>paused ] keep
|
||||
[ drop ] [ start-boids-thread ] if ;
|
||||
|
||||
: randomize-boids ( boids-gadget -- )
|
||||
[ length random-boids ] change-boids drop ;
|
||||
|
||||
:: simulation-panel ( boids-gadget -- gadget )
|
||||
<pile> { 2 2 } >>gap
|
||||
|
||||
2 2 <frame> { 4 4 } >>gap { 0 0 } >>filled-cell
|
||||
|
||||
"polulation" <label> { 0 0 } grid-add
|
||||
initial-population 0 0 200 10 mr:<range>
|
||||
dup [ boids-gadget set-population ] connect
|
||||
horizontal <slider> { 1 0 } grid-add
|
||||
|
||||
"speed" <label> { 0 1 } grid-add
|
||||
boids-gadget dt>> 0 1 10 1 mr:<range>
|
||||
dup [ boids-gadget dt<< ] connect
|
||||
horizontal <slider> { 1 1 } grid-add
|
||||
|
||||
add-gadget
|
||||
|
||||
<shelf> { 2 2 } >>gap
|
||||
"pause" [ drop boids-gadget pause-toggle ]
|
||||
<border-button> add-gadget
|
||||
"randomize" [ drop boids-gadget randomize-boids ]
|
||||
<border-button> add-gadget
|
||||
|
||||
add-gadget
|
||||
|
||||
"simulation" <labeled-gadget> ;
|
||||
|
||||
:: create-gadgets ( -- gadgets )
|
||||
<shelf>
|
||||
<boids-gadget> :> boids-gadget
|
||||
boids-gadget [ start-boids-thread ] keep
|
||||
add-gadget
|
||||
|
||||
<pile> { 2 2 } >>gap 1.0 >>fill
|
||||
|
||||
boids-gadget simulation-panel
|
||||
add-gadget
|
||||
|
||||
boids-gadget behaviours>>
|
||||
[ behavior-panel add-gadget ] each
|
||||
|
||||
add-gadget
|
||||
{ 2 2 } <border> ;
|
||||
|
||||
MAIN-WINDOW: boids { { title "Boids" } }
|
||||
create-gadgets
|
||||
>>gadgets ;
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Eduardo Cavazos
|
||||
Anton Gorenko
|
||||
|
|
@ -0,0 +1,101 @@
|
|||
! Copyright (C) 2008 Eduardo Cavazos.
|
||||
! Copyright (C) 2011 Anton Gorenko.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators.short-circuit kernel
|
||||
locals math math.vectors random sequences ;
|
||||
IN: boids.simulation
|
||||
|
||||
CONSTANT: width 512
|
||||
CONSTANT: height 512
|
||||
|
||||
TUPLE: behaviour
|
||||
{ weight float }
|
||||
{ radius float }
|
||||
{ angle-cos float } ;
|
||||
|
||||
TUPLE: boid
|
||||
{ pos array }
|
||||
{ vel array } ;
|
||||
|
||||
C: <boid> boid
|
||||
|
||||
: vsum ( vecs -- v )
|
||||
{ 0.0 0.0 } [ v+ ] reduce ; inline
|
||||
|
||||
: vavg ( vecs -- v )
|
||||
[ vsum ] [ length ] bi v/n ; inline
|
||||
|
||||
: in-radius? ( self other radius -- ? )
|
||||
[ [ pos>> ] bi@ distance ] dip <= ; inline
|
||||
|
||||
: angle-between ( u v -- angle )
|
||||
[ normalize ] bi@ v. ; inline
|
||||
|
||||
: relative-position ( self other -- v )
|
||||
swap [ pos>> ] bi@ v- ; inline
|
||||
|
||||
:: relative-angle ( self other -- angle )
|
||||
self other relative-position
|
||||
self vel>> angle-between ; inline
|
||||
|
||||
: in-view? ( self other angle-cos -- ? )
|
||||
[ relative-angle ] dip >= ; inline
|
||||
|
||||
:: within-neighborhood? ( self other behaviour -- ? )
|
||||
self other {
|
||||
[ eq? not ]
|
||||
[ behaviour radius>> in-radius? ]
|
||||
[ behaviour angle-cos>> in-view? ]
|
||||
} 2&& ; inline
|
||||
|
||||
:: neighbors ( boid boids behaviour -- neighbors )
|
||||
boid boids [ behaviour within-neighborhood? ] with filter ;
|
||||
|
||||
|
||||
GENERIC: force ( neighbors boid behaviour -- force )
|
||||
|
||||
:: (force) ( boid boids behaviour -- force )
|
||||
boid boids behaviour neighbors
|
||||
[ { 0.0 0.0 } ] [ boid behaviour force ] if-empty ;
|
||||
|
||||
: wrap-pos ( pos -- pos )
|
||||
width height [ 1 - ] bi@ 2array
|
||||
[ [ + ] keep mod ] 2map ;
|
||||
|
||||
:: simulate ( boids behaviours dt -- boids )
|
||||
boids [| boid |
|
||||
boid boids behaviours
|
||||
[ [ (force) ] keep weight>> v*n ] with with map vsum :> a
|
||||
|
||||
boid vel>> a dt v*n v+ normalize :> vel
|
||||
boid pos>> vel dt v*n v+ wrap-pos :> pos
|
||||
|
||||
pos vel <boid>
|
||||
] map ;
|
||||
|
||||
: random-boids ( count -- boids )
|
||||
[
|
||||
width height [ random ] bi@ 2array
|
||||
2 [ 0 1 normal-random-float ] replicate
|
||||
<boid>
|
||||
] replicate ;
|
||||
|
||||
TUPLE: cohesion < behaviour ;
|
||||
TUPLE: alignment < behaviour ;
|
||||
TUPLE: separation < behaviour ;
|
||||
|
||||
C: <cohesion> cohesion
|
||||
C: <alignment> alignment
|
||||
C: <separation> separation
|
||||
|
||||
M: cohesion force ( neighbors boid behaviour -- force )
|
||||
drop [ [ pos>> ] map vavg ] [ pos>> ] bi* v- normalize ;
|
||||
|
||||
M: alignment force ( neighbors boid behaviour -- force )
|
||||
2drop [ vel>> ] map vsum normalize ;
|
||||
|
||||
M:: separation force ( neighbors boid behaviour -- force )
|
||||
behaviour radius>> :> r
|
||||
boid pos>> neighbors
|
||||
[ pos>> v- [ normalize ] [ r v/n ] bi v- ] with map vsum ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Artificial life program simulating the flocking behaviour of birds
|
||||
|
|
@ -1,363 +0,0 @@
|
|||
|
||||
USING: kernel
|
||||
namespaces
|
||||
arrays
|
||||
accessors
|
||||
strings
|
||||
sequences
|
||||
locals
|
||||
threads
|
||||
math
|
||||
math.functions
|
||||
math.trig
|
||||
math.order
|
||||
math.ranges
|
||||
math.vectors
|
||||
random
|
||||
calendar
|
||||
opengl.gl
|
||||
opengl
|
||||
ui
|
||||
ui.gadgets
|
||||
ui.gadgets.tracks
|
||||
ui.gadgets.frames
|
||||
ui.gadgets.grids
|
||||
ui.render
|
||||
multi-methods
|
||||
multi-method-syntax
|
||||
combinators.short-circuit
|
||||
processing.shapes
|
||||
flatland ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
IN: boids
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: constrain ( n a b -- n ) rot min max ;
|
||||
|
||||
: angle-between ( vec vec -- angle )
|
||||
[ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
|
||||
|
||||
: relative-angle ( self other -- angle )
|
||||
over vel>> -rot relative-position angle-between ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: in-radius? ( self other radius -- ? ) [ distance ] dip <= ;
|
||||
: in-view? ( self other angle -- ? ) [ relative-angle ] dip 2 / <= ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: vsum ( vector-of-vectors -- vec ) { 0 0 } [ v+ ] reduce ;
|
||||
|
||||
: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
|
||||
|
||||
: average-position ( boids -- pos ) [ pos>> ] map vaverage ;
|
||||
: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <boid> < <vel> ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <behaviour>
|
||||
{ weight initial: 1.0 }
|
||||
{ view-angle initial: 180 }
|
||||
{ radius } ;
|
||||
|
||||
TUPLE: <cohesion> < <behaviour> { radius initial: 75 } ;
|
||||
TUPLE: <alignment> < <behaviour> { radius initial: 50 } ;
|
||||
TUPLE: <separation> < <behaviour> { radius initial: 25 } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: within-neighborhood? ( SELF OTHER BEHAVIOUR -- ? )
|
||||
|
||||
SELF OTHER
|
||||
{
|
||||
[ BEHAVIOUR radius>> in-radius? ]
|
||||
[ BEHAVIOUR view-angle>> in-view? ]
|
||||
[ eq? not ]
|
||||
}
|
||||
2&& ;
|
||||
|
||||
:: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
|
||||
OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: normalize* ( u -- v ) { 0.001 0.001 } v+ normalize ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
GENERIC: force* ( sequence <boid> <behaviour> -- force )
|
||||
|
||||
:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
|
||||
OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
|
||||
|
||||
:: alignment-force ( OTHERS SELF BEHAVIOUR -- force )
|
||||
OTHERS average-velocity normalize* BEHAVIOUR weight>> v*n ;
|
||||
|
||||
:: separation-force ( OTHERS SELF BEHAVIOUR -- force )
|
||||
SELF pos>> OTHERS average-position v- normalize* BEHAVIOUR weight>> v*n ;
|
||||
|
||||
METHOD: force* ( sequence <boid> <cohesion> -- force ) cohesion-force ;
|
||||
METHOD: force* ( sequence <boid> <alignment> -- force ) alignment-force ;
|
||||
METHOD: force* ( sequence <boid> <separation> -- force ) separation-force ;
|
||||
|
||||
:: force ( OTHERS SELF BEHAVIOUR -- force )
|
||||
SELF OTHERS BEHAVIOUR neighborhood
|
||||
[ { 0 0 } ]
|
||||
[ SELF BEHAVIOUR force* ]
|
||||
if-empty ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: random-boids ( count -- boids )
|
||||
[
|
||||
drop
|
||||
<boid> new
|
||||
2 [ drop 1000 random ] map >>pos
|
||||
2 [ drop -10 10 [a,b] random ] map >>vel
|
||||
]
|
||||
map ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: draw-boid ( boid -- )
|
||||
glPushMatrix
|
||||
dup pos>> gl-translate-2d
|
||||
vel>> first2 rect> arg rad>deg 0 0 1 glRotated
|
||||
{ { 0 5 } { 0 -5 } { 20 0 } } triangle
|
||||
fill-mode
|
||||
glPopMatrix ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: gadget->sky ( gadget -- sky ) { 0 0 } swap dim>> <rectangle> boa ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
|
||||
|
||||
TUPLE: <boids-gadget> < gadget paused boids behaviours time-slice ;
|
||||
|
||||
M: <boids-gadget> pref-dim* ( <boids-gadget> -- dim ) drop { 600 400 } ;
|
||||
M: <boids-gadget> ungraft* ( <boids-gadget> -- ) t >>paused drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-system ( BOIDS-GADGET -- )
|
||||
|
||||
[let | SKY [ BOIDS-GADGET gadget->sky ]
|
||||
BOIDS [ BOIDS-GADGET boids>> ]
|
||||
TIME-SLICE [ BOIDS-GADGET time-slice>> ]
|
||||
BEHAVIOURS [ BOIDS-GADGET behaviours>> ] |
|
||||
|
||||
BOIDS
|
||||
|
||||
[| SELF |
|
||||
|
||||
[wlet | force-due-to [| BEHAVIOUR | BOIDS SELF BEHAVIOUR force ] |
|
||||
|
||||
! F = m a. M is 1. So F = a.
|
||||
|
||||
[let | ACCEL [ BEHAVIOURS [ force-due-to ] map vsum ] |
|
||||
|
||||
[let | POS [ SELF pos>> SELF vel>> TIME-SLICE v*n v+ ]
|
||||
VEL [ SELF vel>> ACCEL TIME-SLICE v*n v+ ] |
|
||||
|
||||
[let | POS [ POS SKY wrap ]
|
||||
VEL [ VEL normalize* ] |
|
||||
|
||||
T{ <boid> f POS VEL } ] ] ] ]
|
||||
|
||||
]
|
||||
|
||||
map
|
||||
|
||||
BOIDS-GADGET (>>boids) ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
|
||||
origin get
|
||||
[ BOIDS-GADGET boids>> [ draw-boid ] each ]
|
||||
with-translation ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: start-boids-thread ( GADGET -- )
|
||||
GADGET f >>paused drop
|
||||
[
|
||||
[
|
||||
GADGET paused>>
|
||||
[ f ]
|
||||
[ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
|
||||
if
|
||||
]
|
||||
loop
|
||||
]
|
||||
in-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: default-behaviours ( -- seq )
|
||||
{ <cohesion> <alignment> <separation> } [ new ] map ;
|
||||
|
||||
: boids-gadget ( -- gadget )
|
||||
<boids-gadget> new-gadget
|
||||
100 random-boids >>boids
|
||||
default-behaviours >>behaviours
|
||||
10 >>time-slice
|
||||
t >>clipped? ;
|
||||
|
||||
: run-boids ( -- ) boids-gadget dup "Boids" open-window start-boids-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USING: math.parser
|
||||
ui.gadgets.labels
|
||||
ui.gadgets.buttons
|
||||
ui.gadgets.packs ;
|
||||
|
||||
: truncate-number ( n -- n ) 10 * round 10 / ;
|
||||
|
||||
:: make-behaviour-control ( NAME BEHAVIOUR -- gadget )
|
||||
[let | NAME-LABEL [ NAME <label> reverse-video-theme ]
|
||||
VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
|
||||
|
||||
[wlet | update-value-label [ ! ( -- )
|
||||
BEHAVIOUR weight>> truncate-number number>string
|
||||
VALUE-LABEL
|
||||
(>>string) ] |
|
||||
|
||||
update-value-label
|
||||
|
||||
<pile> 1 >>fill
|
||||
{ 1 0 } <track>
|
||||
NAME-LABEL 0.5 track-add
|
||||
VALUE-LABEL 0.5 track-add
|
||||
add-gadget
|
||||
|
||||
"+0.1"
|
||||
[
|
||||
drop
|
||||
BEHAVIOUR [ 0.1 + ] change-weight drop
|
||||
update-value-label
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
"-0.1"
|
||||
[
|
||||
drop
|
||||
BEHAVIOUR weight>> 0.1 >
|
||||
[
|
||||
BEHAVIOUR [ 0.1 - ] change-weight drop
|
||||
update-value-label
|
||||
]
|
||||
when
|
||||
]
|
||||
<bevel-button> add-gadget ] ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: make-population-control ( BOIDS-GADGET -- gadget )
|
||||
[let | VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
|
||||
|
||||
[wlet | update-value-label [ ( -- )
|
||||
BOIDS-GADGET boids>> length number>string
|
||||
VALUE-LABEL
|
||||
(>>string) ] |
|
||||
|
||||
update-value-label
|
||||
|
||||
<pile> 1 >>fill
|
||||
|
||||
{ 1 0 } <track>
|
||||
"Population: " <label> reverse-video-theme 0.5 track-add
|
||||
VALUE-LABEL 0.5 track-add
|
||||
add-gadget
|
||||
|
||||
"Add 10"
|
||||
[
|
||||
drop
|
||||
BOIDS-GADGET
|
||||
BOIDS-GADGET boids>> 10 random-boids append
|
||||
>>boids
|
||||
drop
|
||||
update-value-label
|
||||
]
|
||||
<bevel-button>
|
||||
add-gadget
|
||||
|
||||
"Sub 10"
|
||||
[
|
||||
drop
|
||||
BOIDS-GADGET boids>> length 10 >
|
||||
[
|
||||
BOIDS-GADGET
|
||||
BOIDS-GADGET boids>> 10 tail
|
||||
>>boids
|
||||
drop
|
||||
update-value-label
|
||||
]
|
||||
when
|
||||
]
|
||||
<bevel-button>
|
||||
add-gadget ] ] ( gadget -- gadget ) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: pause-toggle ( BOIDS-GADGET -- )
|
||||
BOIDS-GADGET paused>>
|
||||
[ BOIDS-GADGET start-boids-thread ]
|
||||
[ BOIDS-GADGET t >>paused drop ]
|
||||
if ;
|
||||
|
||||
:: randomize-boids ( BOIDS-GADGET -- )
|
||||
BOIDS-GADGET BOIDS-GADGET boids>> length random-boids >>boids drop ;
|
||||
|
||||
: boids-app ( -- )
|
||||
|
||||
[let | BOIDS-GADGET [ boids-gadget ] |
|
||||
|
||||
<frame>
|
||||
|
||||
<shelf>
|
||||
|
||||
1 >>fill
|
||||
|
||||
"Pause" [ drop BOIDS-GADGET pause-toggle ] <bevel-button> add-gadget
|
||||
|
||||
"Randomize"
|
||||
[ drop BOIDS-GADGET randomize-boids ] <bevel-button> add-gadget
|
||||
|
||||
BOIDS-GADGET make-population-control add-gadget
|
||||
|
||||
"Cohesion: " BOIDS-GADGET behaviours>> first make-behaviour-control
|
||||
"Alignment: " BOIDS-GADGET behaviours>> second make-behaviour-control
|
||||
"Separation: " BOIDS-GADGET behaviours>> third make-behaviour-control
|
||||
|
||||
[ add-gadget ] tri@
|
||||
|
||||
@top grid-add
|
||||
|
||||
BOIDS-GADGET @center grid-add
|
||||
|
||||
"Boids" open-window
|
||||
|
||||
BOIDS-GADGET start-boids-thread ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: boids-main ( -- ) [ boids-app ] with-ui ;
|
||||
|
||||
MAIN: boids-main
|
||||
|
|
@ -1 +0,0 @@
|
|||
Artificial life program simulating simulating the flocking behaviour of birds
|
||||
Loading…
Reference in New Issue