1 ! Copyright (C) 2008 Eduardo Cavazos.
2 ! Copyright (C) 2011 Anton Gorenko.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays combinators.short-circuit kernel
5 locals math math.vectors random sequences ;
23 { 0.0 0.0 } [ v+ ] reduce ; inline
26 [ vsum ] [ length ] bi v/n ; inline
28 : in-radius? ( self other radius -- ? )
29 [ [ pos>> ] bi@ distance ] dip <= ; inline
31 : angle-between ( u v -- angle )
32 [ normalize ] bi@ v. ; inline
34 : relative-position ( self other -- v )
35 swap [ pos>> ] bi@ v- ; inline
37 :: relative-angle ( self other -- angle )
38 self other relative-position
39 self vel>> angle-between ; inline
41 : in-view? ( self other angle-cos -- ? )
42 [ relative-angle ] dip >= ; inline
44 :: within-neighborhood? ( self other behaviour -- ? )
47 [ behaviour radius>> in-radius? ]
48 [ behaviour angle-cos>> in-view? ]
51 :: neighbors ( boid boids behaviour -- neighbors )
52 boid boids [ behaviour within-neighborhood? ] with filter ;
55 GENERIC: force ( neighbors boid behaviour -- force )
57 :: (force) ( boid boids behaviour -- force )
58 boid boids behaviour neighbors
59 [ { 0.0 0.0 } ] [ boid behaviour force ] if-empty ;
61 : wrap-pos ( pos -- pos )
62 width height [ 1 - ] bi@ 2array
63 [ [ + ] keep mod ] 2map ;
65 :: simulate ( boids behaviours dt -- boids )
68 [ [ (force) ] keep weight>> v*n ] with with map vsum :> a
70 boid vel>> a dt v*n v+ normalize :> vel
71 boid pos>> vel dt v*n v+ wrap-pos :> pos
76 : random-boids ( count -- boids )
78 width height [ random ] bi@ 2array
79 2 [ 0 1 normal-random-float ] replicate
83 TUPLE: cohesion < behaviour ;
84 TUPLE: alignment < behaviour ;
85 TUPLE: separation < behaviour ;
87 C: <cohesion> cohesion
88 C: <alignment> alignment
89 C: <separation> separation
91 M: cohesion force ( neighbors boid behaviour -- force )
92 drop [ [ pos>> ] map vavg ] [ pos>> ] bi* v- normalize ;
94 M: alignment force ( neighbors boid behaviour -- force )
95 2drop [ vel>> ] map vsum normalize ;
97 M:: separation force ( neighbors boid behaviour -- force )
98 behaviour radius>> :> r
100 [ pos>> v- [ normalize ] [ r v/n ] bi v- ] with map vsum ;