diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index 857abcf5d3..b0d5bda508 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -1,81 +1,44 @@ -USING: kernel namespaces - math - math.constants - math.functions - math.order - math.vectors - math.trig - math.ranges - combinators arrays sequences random vars - combinators.lib - combinators.short-circuit +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.smart + processing.shapes flatland ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IN: boids ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: boid < ; - -C: boid - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VAR: boids -VAR: world-size -VAR: time-slice - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VAR: cohesion-weight -VAR: alignment-weight -VAR: separation-weight - -VAR: cohesion-view-angle -VAR: alignment-view-angle -VAR: separation-view-angle - -VAR: cohesion-radius -VAR: alignment-radius -VAR: separation-radius - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: init-variables ( -- ) - 1.0 >cohesion-weight - 1.0 >alignment-weight - 1.0 >separation-weight - - 75 >cohesion-radius - 50 >alignment-radius - 25 >separation-radius - - 180 >cohesion-view-angle - 180 >alignment-view-angle - 180 >separation-view-angle - - 10 >time-slice ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! random-boid and random-boids -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: random-pos ( -- pos ) world-size> [ random ] map ; - -: random-vel ( -- vel ) 2 [ drop -10 10 [a,b] random ] map ; - -: random-boid ( -- boid ) random-pos random-vel ; - -: random-boids ( n -- boids ) [ drop random-boid ] map ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : constrain ( n a b -- n ) rot min max ; : angle-between ( vec vec -- angle ) - 2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ; + [ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -86,19 +49,47 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: in-range? ( self other radius -- ? ) >r distance r> <= ; +TUPLE: < ; -: in-view? ( self other angle -- ? ) >r relative-angle r> 2 / <= ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: + { weight initial: 1.0 } + { view-angle initial: 180 } + { radius } ; + +TUPLE: < { radius initial: 75 } ; +TUPLE: < { radius initial: 50 } ; +TUPLE: < { radius initial: 25 } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: within-neighborhood? ( SELF OTHER BEHAVIOUR -- ? ) + + SELF OTHER + { + [ BEHAVIOUR radius>> in-radius? ] + [ BEHAVIOUR view-angle>> in-view? ] + [ eq? not ] + } + && ; + +:: neighborhood ( SELF OTHERS BEHAVIOUR -- boids ) + OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -106,127 +97,264 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! average_position(neighbors) - self_position +GENERIC: force* ( sequence -- force ) -: within-cohesion-neighborhood? ( self other -- ? ) - { [ cohesion-radius> in-range? ] - [ cohesion-view-angle> in-view? ] - [ eq? not ] } - 2&& ; +:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force ) + OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ; -: cohesion-neighborhood ( self -- boids ) - boids> [ within-cohesion-neighborhood? ] with filter ; +:: alignment-force ( OTHERS SELF BEHAVIOUR -- force ) + OTHERS average-velocity normalize* BEHAVIOUR weight>> v*n ; -: cohesion-force ( self -- force ) - dup cohesion-neighborhood - dup empty? - [ 2drop { 0 0 } ] - [ average-position swap pos>> v- normalize* cohesion-weight> v*n ] +:: separation-force ( OTHERS SELF BEHAVIOUR -- force ) + SELF pos>> OTHERS average-position v- normalize* BEHAVIOUR weight>> v*n ; + +METHOD: force* ( sequence -- force ) cohesion-force ; +METHOD: force* ( sequence -- force ) alignment-force ; +METHOD: force* ( sequence -- force ) separation-force ; + +:: force ( OTHERS SELF BEHAVIOUR -- force ) + SELF OTHERS BEHAVIOUR neighborhood + [ { 0 0 } ] + [ SELF BEHAVIOUR force* ] + if-empty ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: random-boids ( count -- boids ) + [ + drop + 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>> boa ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax + +TUPLE: < gadget paused boids behaviours time-slice ; + +M: pref-dim* ( -- dim ) drop { 600 400 } ; +M: ungraft* ( -- ) t >>paused drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M:: draw-gadget* ( 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{ f POS VEL } ] ] ] ] + + ] + + map + + BOIDS-GADGET (>>boids) + + origin get + [ BOIDS-GADGET boids>> [ draw-boid ] each ] + with-translation ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: start-boids-thread ( GADGET -- ) + GADGET f >>paused drop + [ + [ + GADGET paused>> + [ f ] + [ GADGET relayout-1 25 milliseconds sleep t ] + if + ] + loop + ] + in-thread ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: default-behaviours ( -- seq ) + { } [ new ] map ; + +: boids-gadget ( -- 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