Merge remote-tracking branch 'ex-rzr/fixes'
John Benediktsson
commit
60bf9d49ca
|
|
@ -1 +1,2 @@
|
||||||
Eduardo Cavazos
|
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