#lang planet dyoo/whalesong (require (planet dyoo/whalesong/js) (planet dyoo/whalesong/image) (planet dyoo/whalesong/web-world) (planet dyoo/whalesong/resource)) (define-resource view.html) ;; Boid flocking behavior. ;; ;; http://www.vergenet.net/~conrad/boids/pseudocode.html ;; ;; ;; A Boid has an identity, a velocity and position vector, as well as a color (define-struct boid (id velocity position color)) (define width (viewport-width)) (define height (viewport-height)) ;; A vec represents a vector in 2d space. (define-struct vec (x y)) ;; A mass-data represents the total velocity and position ;; of a collection of boids. (define-struct mass-data (center-velocity center-position)) ;; (: vec+ (vec vec -> vec)) ;; Adds two vecs together. (define (vec+ v1 v2) (make-vec (+ (vec-x v1) (vec-x v2)) (+ (vec-y v1) (vec-y v2)))) ;; Let's test vec+. (check-expect (vec+ (make-vec 3 4) (make-vec 5 6)) (make-vec 8 10)) (check-expect (vec+ (make-vec 1024 2) (make-vec -1024 -1)) (make-vec 0 1)) ;; (: vec- (vec vec -> vec)) ;; Subtracts one vec from another. (define (vec- v1 v2) (make-vec (- (vec-x v1) (vec-x v2)) (- (vec-y v1) (vec-y v2)))) (check-expect (vec- (make-vec 3 4) (make-vec 5 6)) (make-vec -2 -2)) (check-expect (vec- (make-vec 1024 2) (make-vec -1024 -1)) (make-vec 2048 3)) ;; (: vec-scale (vec Real -> vec)) ;; Scales a vector by a certain scalar. (define (vec-scale v n) (make-vec (* (vec-x v) n) (* (vec-y v) n))) (check-expect (vec-scale (make-vec 3 4) 7) (make-vec 21 28)) (check-expect (vec-scale (make-vec 1 2) 1/2) (make-vec 1/2 1)) ;; (: square (Real -> Real)) (define (sqr x) (* x x)) (check-expect (sqr 10) 100) (check-expect (sqr -2) 4) ;; (: vec-distance^2 (vec vec -> Real)) ;; Produces the square of the distance between two vecs. (define (vec-distance^2 v1 v2) (+ (sqr (- (vec-x v1) (vec-x v2))) (sqr (- (vec-y v1) (vec-y v2))))) (check-expect (vec-distance^2 (make-vec 0 0) (make-vec 3 4)) 25) (check-expect (vec-distance^2 (make-vec 1924 2329) (make-vec 1924 2328)) 1) ;; (: vec-center ((Listof vec) -> vec)) ;; Given a list of vecs, produces the center, assuming each vec has the same mass. (define (vec-center vecs) (cond [(empty? vecs) ;; We'll raise a runtime error if we ever try to take the center of the ;; empty set. (error 'vec-center "trying to take the center of an empty collection of vecs")] [else (vec-scale (foldl vec+ (first vecs) (rest vecs)) (/ 1 (length vecs)))])) (check-expect (vec-center (list (make-vec 1 1) (make-vec 2 7) (make-vec 1 3))) (make-vec 4/3 11/3)) (check-expect (vec-center (list (make-vec 5 0) (make-vec 4 2))) (make-vec 9/2 1)) (define (vec-mag v) (sqrt (+ (sqr (vec-x v)) (sqr (vec-y v))))) ;; (: vec-normalize (vec -> vec)) ;; Produces a vector of length 1 going in the same direction. (define (vec-normalize v) (let ([n (vec-mag v)]) (make-vec (/ (vec-x v) n) (/ (vec-y v) n)))) ;; collect-mass-data: (Listof boid) -> mass-data (define (collect-mass-data boids) (let ([the-center-velocity (vec-center (map boid-velocity boids))] [the-center-position (vec-center (map boid-position boids))]) (make-mass-data the-center-velocity the-center-position))) ;; (: rule-1 (boid (Listof boid) -> vec)) ;; Boids try to fly toward the center of mass of neighboring boids. ;; Produce a vector pointing to the center of the boid cloud. (define (rule-1 boid boids mass-data) (vec- (mass-data-center-position mass-data) (boid-position boid))) ;; (: rule-2 (boid (Listof boid) -> vec)) ;; Boids try to keep a small distance away from other boids. (define (rule-2 boid boids) (foldl (lambda (neighbor the-center) (cond [(eq? boid neighbor) the-center] [(too-close? boid neighbor) (vec- the-center (vec- (boid-position neighbor) (boid-position boid)))] [else the-center])) (make-vec 0 0) boids)) ;; (: too-close? (boid boid -> Boolean)) ;; Produces true if the two boids are too close for comfort. (define (too-close? b1 b2) (let ([threshold (sqr 15)]) (< (vec-distance^2 (boid-position b1) (boid-position b2)) threshold))) ;; (: rule-3 (boid (Listof boid) -> vec)) ;; Boids try to match velocity with near boids. (define (rule-3 boid boids mass-data) (vec- (mass-data-center-velocity mass-data) (boid-velocity boid))) ;; (: move-boid (boid (Listof boid) -> boid)) ;; Moves a boid according to the rules. (define (move-boid b boids mass-data) (let ([rule-1-scale-factor 0.05] [rule-2-scale-factor 0.1] [rule-3-scale-factor 1/8] [rule-4-scale-factor 0.8]) (let ([new-velocity (vec+ (boid-velocity b) (vec+ (vec-scale (rule-1 b boids mass-data) rule-1-scale-factor) (vec+ (vec-scale (rule-2 b boids) rule-2-scale-factor) (vec+ (vec-scale (rule-3 b boids mass-data) rule-3-scale-factor) (vec-scale (rule-4 b) rule-4-scale-factor)))))] [new-position (vec+ (boid-position b) (boid-velocity b))]) (make-boid (boid-id b) new-velocity new-position (boid-color b))))) ;; Boids should avoid going out of bounds. If they stray out of bounds, ;; nudge them toward the center of the screen. (define (rule-4 boid) (cond [(out-of-bounds? (boid-position boid)) (vec-normalize (vec- (make-vec (random width) (random height)) (boid-position boid)))] [else (make-vec 0 0)])) (define (out-of-bounds? v) (or (not (<= 100 (vec-x v) 540)) (not (<= 100 (vec-y v) 380)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; (: tick ((Listof boid) dom -> (Listof boid))) (define (tick boids dom) (map (lambda (b) (let ([mass-data (collect-mass-data (boid-neighborhood b boids 40))]) (cap-boid-velocity (move-boid b boids mass-data) 15))) boids)) (define (boid-neighborhood b boids n) (filter (lambda (b2) (< (vec-mag (vec- (boid-position b) (boid-position b2))) n)) boids)) (define (cap-boid-velocity b mag) (make-boid (boid-id b) (vec-cap (boid-velocity b) mag) (boid-position b) (boid-color b))) (define (vec-cap v n) (cond [(> (vec-mag v) n) (vec-scale (vec-normalize v) n)] [else v])) (define (slow-down-boids boids) (map (lambda (b) (make-boid (boid-id b) (vec-scale (boid-velocity b) 0.9) (boid-position b) (boid-color b))) boids)) (define (speed-up-boids boids) (map (lambda (b) (make-boid (boid-id b) (vec-scale (boid-velocity b) 1.1) (boid-position b) (boid-color b))) boids)) ;; draw: (listof boid) view -> scene (define (draw boids dom) (foldl (lambda (boid dom) (define with-left (update-view-css (view-focus dom (boid-id boid)) "left" (format "~apx" (vec-x (boid-position boid))))) (define with-left-and-top (update-view-css with-left "top" (format "~apx" (vec-y (boid-position boid))))) with-left-and-top) dom boids)) ;; make-random-boid: -> boid ;; Makes a random boid that starts near the upper left corner, ;; drifting downward. (define (make-random-boid) (make-boid (fresh-id) (make-vec (random 10) (random 10)) (make-vec (random width) (random height)) (make-color (random 255) (random 255) (random 255)))) (define (new-population) (build-list 10 (lambda (i) (make-random-boid)))) ;; visualize: -> void ;; Animates a scene of the boids flying around. (define (visualize) (define population (new-population)) (define view-with-boids (view-append-child (view-focus (->view view.html) "playground") (xexp->dom `(div ,@(map (lambda (b) `(div (@ (id ,(boid-id b)) (class "boid")) nbsp)) population))))) (define view-with-colored-boids (foldl (lambda (b view) (update-view-css (view-focus view (boid-id b)) "background" (format "rgb(~a,~a,~a)" (color-red (boid-color b)) (color-green (boid-color b)) (color-blue (boid-color b))))) view-with-boids population)) (big-bang population (initial-view view-with-colored-boids) (on-tick tick 1/20) (to-draw draw))) (visualize)