steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

fix 'boids' and move it from unmantained to extra;

db4
Anton Gorenko 2011-05-22 17:07:55 +06:00
parent 43e4cf8754
commit 588af74590
7 changed files with 264 additions and 364 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
unmaintained/boids/authors.txt → extra/boids/authors.txt
View File

@ -1 +1,2 @@
Eduardo Cavazos
Anton Gorenko

159
extra/boids/boids.factor Normal file
View File

@ -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 ;

2
extra/boids/simulation/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Eduardo Cavazos
Anton Gorenko

101
extra/boids/simulation/simulation.factor Normal file
View File

@ -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 ;

1
extra/boids/summary.txt Normal file
View File

@ -0,0 +1 @@
Artificial life program simulating the flocking behaviour of birds

363
unmaintained/boids/boids.factor
View File

@ -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
unmaintained/boids/summary.txt
View File

@ -1 +0,0 @@
Artificial life program simulating simulating the flocking behaviour of birds