--- /dev/null
+! 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 ;
+
--- /dev/null
+! 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 ;
+
+++ /dev/null
-
-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
\ No newline at end of file
projects / factor.git / commitdiff