-
-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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+! 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 colors
+kernel literals math math.functions math.trig models
+models.range opengl opengl.demo-support opengl.gl sequences
+threads ui ui.commands 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 ui.tools.common ;
+
+QUALIFIED-WITH: models.range mr
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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+TUPLE: boids-gadget < gadget paused boids behaviors dt ;
-: normalize* ( u -- v ) { 0.001 0.001 } v+ normalize ;
+CONSTANT: initial-population 100
+CONSTANT: initial-dt 5
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: initial-behaviors ( -- seq )
+ 1.0 75 -0.1 <cohesion>
+ 1.0 40 -0.5 <alignment>
+ 1.0 25 -1.0 <separation>
+ 3array ;
-GENERIC: force* ( sequence <boid> <behaviour> -- force )
+: <boids-gadget> ( -- gadget )
+ boids-gadget new
+ t >>clipped?
+ ${ WIDTH HEIGHT } >>pref-dim
+ initial-population random-boids >>boids
+ initial-behaviors >>behaviors
+ initial-dt >>dt ;
-:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
- OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
+M: boids-gadget ungraft*
+ t >>paused drop ;
-:: 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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: vec>deg ( vec -- deg )
+ first2 rect> arg rad>deg ; inline
: 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 |
+ 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 -- )
+ boids>> draw-boids ;
+
+: iterate-system ( boids-gadget -- )
+ dup [ boids>> ] [ behaviors>> ] [ dt>> ] tri
+ simulate >>boids drop ;
+
+:: start-boids-thread ( gadget -- )
+ [
+ [ gadget paused>> ]
+ [
+ gadget iterate-system
+ gadget relayout-1
+ 10 milliseconds sleep
+ ] until
+ ] in-thread ;
- [wlet | force-due-to [| BEHAVIOUR | BOIDS SELF BEHAVIOUR force ] |
+TUPLE: range-observer quot ;
- ! F = m a. M is 1. So F = a.
-
- [let | ACCEL [ BEHAVIOURS [ force-due-to ] map vsum ] |
+M: range-observer model-changed
+ [ range-value ] dip quot>> call( value -- ) ;
- [let | POS [ SELF pos>> SELF vel>> TIME-SLICE v*n v+ ]
- VEL [ SELF vel>> ACCEL TIME-SLICE v*n v+ ] |
+: connect ( range-model quot -- )
+ range-observer boa swap add-connection ;
- [let | POS [ POS SKY wrap ]
- VEL [ VEL normalize* ] |
-
- T{ <boid> f POS VEL } ] ] ] ]
+:: behavior-panel ( behavior -- gadget )
+ 2 3 <frame> white-interior { 2 4 } >>gap { 0 0 } >>filled-cell
- ]
-
- map
+ "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
- BOIDS-GADGET (>>boids) ] ;
+ "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
-M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
- origin get
- [ BOIDS-GADGET boids>> [ draw-boid ] each ]
- with-translation ;
+ { 5 5 } <border> white-interior
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ behavior class-of name>> COLOR: gray <framed-labeled-gadget> ;
-:: 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 ) ;
+:: set-population ( n boids-gadget -- )
+ boids-gadget [
+ dup length n - dup 0 >
+ [ head* ]
+ [ neg random-boids append ] if
+ ] change-boids drop ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+<PRIVATE
+: find-boids-gadget ( gadget -- boids-gadget )
+ dup boids-gadget? [ children>> [ boids-gadget? ] find nip ] unless ;
+PRIVATE>
-:: pause-toggle ( BOIDS-GADGET -- )
- BOIDS-GADGET paused>>
- [ BOIDS-GADGET start-boids-thread ]
- [ BOIDS-GADGET t >>paused drop ]
- if ;
+: com-pause ( boids-gadget -- )
+ find-boids-gadget
+ dup paused>> not [ >>paused ] keep
+ [ drop ] [ start-boids-thread ] if ;
-:: randomize-boids ( BOIDS-GADGET -- )
- BOIDS-GADGET BOIDS-GADGET boids>> length random-boids >>boids drop ;
+: com-randomize ( boids-gadget -- )
+ find-boids-gadget
+ [ length random-boids ] change-boids relayout-1 ;
-: boids-app ( -- )
+:: simulation-panel ( boids-gadget -- gadget )
+ <pile> white-interior
- [let | BOIDS-GADGET [ boids-gadget ] |
+ 2 2 <frame> { 2 4 } >>gap { 0 0 } >>filled-cell
- <frame>
+ "population" <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
- <shelf>
+ "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
- 1 >>fill
+ { 5 5 } <border> add-gadget
- "Pause" [ drop BOIDS-GADGET pause-toggle ] <bevel-button> add-gadget
+ <shelf> { 2 2 } >>gap
+ "pause" [ drop boids-gadget com-pause ]
+ <border-button> add-gadget
+ "randomize" [ drop boids-gadget com-randomize ]
+ <border-button> add-gadget
- "Randomize"
- [ drop BOIDS-GADGET randomize-boids ] <bevel-button> add-gadget
+ { 5 5 } <border> 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
+ "simulation" COLOR: gray <framed-labeled-gadget> ;
- [ add-gadget ] tri@
+TUPLE: boids-frame < pack ;
- @top grid-add
+:: <boids-frame> ( -- boids-frame )
+ boids-frame new horizontal >>orientation
+ <boids-gadget> :> boids-gadget
+ boids-gadget [ start-boids-thread ] keep
+ add-gadget
- BOIDS-GADGET @center grid-add
+ <pile> { 5 5 } >>gap 1.0 >>fill
- "Boids" open-window
+ boids-gadget simulation-panel
+ add-gadget
- BOIDS-GADGET start-boids-thread ] ;
+ boids-gadget behaviors>>
+ [ behavior-panel add-gadget ] each
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ { 5 5 } <border> add-gadget ;
-: boids-main ( -- ) [ boids-app ] with-ui ;
+boids-frame "touchbar" f {
+ { f com-pause }
+ { f com-randomize }
+} define-command-map
-MAIN: boids-main
\ No newline at end of file
+MAIN-WINDOW: boids { { title "Boids" } }
+ <boids-frame> >>gadgets ;
projects / factor.git / blobdiff