357 lines
9.5 KiB
Racket
357 lines
9.5 KiB
Racket
#lang planet dyoo/whalesong
|
|
|
|
(require (planet dyoo/whalesong/js)
|
|
(planet dyoo/whalesong/image)
|
|
(planet dyoo/whalesong/web-world)
|
|
(planet dyoo/whalesong/resource))
|
|
|
|
|
|
(define-resource index.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 index.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) |