Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Party Planner
(ns party-planner
"A. K. Dewdney-style party simulation. Each guest has an ideal
distance from each other guest that they want to achieve.
From Scientific American, September 1987: 'Computer Recreations:
Diverse personalities search for social equilibrium at a computer
party.'"
(:use [enchilada :only [canvas ctx value-of canvas-size]]
[jayq.core :only [show]]
[monet.core :only [animation-frame]]
[monet.canvas :only [save restore
begin-path move-to line-to close-path
stroke stroke-style fill fill-rect fill-style
rotate translate]]
[party-planner.rules :only [step make-guests]])
(:require [party-planner.vector :refer [heading]]))
(def r (js/parseFloat (value-of :r 3.0)))
(def width (first (canvas-size)))
(def height (second (canvas-size)))
(def stepper (step width height r))
(def rng (range (js/parseInt (value-of :guests 5))))
(def pi-over-2 (/ Math/PI 2))
(def guests
(make-guests rng (/ width 2) (/ height 2)))
(defn render! [ctx guests size]
(->
ctx
(fill-style :white)
(fill-rect {:x 0 :y 0 :w width :h height})
(stroke-style :darkcyan)
(fill-style :lightcyan))
(doseq [guest guests
:let [[x y] (:location guest)
theta (+ (heading (:velocity guest)) pi-over-2)]]
(->
ctx
(save)
(translate x y)
(rotate theta)
(begin-path)
(move-to 0 (* size -2))
(line-to (- size) (* size 2))
(line-to size (* size 2))
(close-path)
(fill)
(stroke)
(restore))))
(defn update [guests idx]
(assoc guests idx (stepper (guests idx) guests)))
(defn animate [ctx guests size]
(letfn [(loop [state]
(fn []
(animation-frame (loop (reduce update state rng)))
(render! ctx state size)))]
((loop guests))))
(show canvas)
(animate ctx guests r)
(ns party-planner.rules
(:require [party-planner.vector :refer [make-vector rand-vector add sub mult div normalize dist mag limit add-all]]))
(def friction 0.99)
(def max-speed 2.0)
(def max-force 0.03)
(def zero-vec (make-vector 0 0))
(defn rand-ideal-distance
"Selects an ideal distance from a bimodal binomial distribution:
Modes are 75 and 225."
[]
(+
(if (< (rand) 0.5)
0.0
150.0)
(+ (rand 50) (rand 50) (rand 50))))
(defn assign-ideal-distances [guest peers]
(assoc guest
:ideals
(reduce (fn [ideals peer]
(if (= guest peer)
ideals
(assoc ideals (:id peer) (rand-ideal-distance))))
{}
peers)))
(defn make-guests [rng x y]
(let [guests (map (fn [id]
{:id id
:location (make-vector x y)
:velocity (rand-vector 1)
:acceleration (make-vector 0 0)
:max-speed (rand 3.0)})
rng)]
(mapv #(assign-ideal-distances %1 guests)
guests)))
(defn- apply-forces [guest forces]
(assoc guest
:acceleration (add
(:acceleration guest)
(add-all forces))))
(defn- diff [location1 location2 dist]
(->
(sub location1 location2)
normalize
(div dist)))
(defn sign [x]
(cond (neg? x) -1
(pos? x) 1
:else 0))
(def ideal-distance
{:init [0 zero-vec]
:close-enough? pos?
:accumulator
(fn [guest other distance [cnt sum]]
(let [other-id (:id other)]
(if (contains? (:ideals guest) other-id)
(let [ideal-dist ((:ideals guest) other-id)
dist-diff (- ideal-dist distance)]
(let [ns (add
sum
(-> (sub (:location guest) (:location other))
normalize
(mult (* 0.001 (sign dist-diff) (Math/sqrt (Math/abs dist-diff))))))]
[(inc cnt) ns]))
[(inc cnt) sum])))
:final
(fn [guest [count sum]]
(if (pos? count)
(-> sum
(limit max-force))
zero-vec))})
(defn- calc-forces
[guest peers & forces]
(loop [ps peers
data (map :init forces)]
(if (empty? ps)
(map (fn [force datum] ((:final force) guest datum)) forces data)
(let [other (first ps)
distance (dist (:location guest) (:location other))]
(recur
(next ps)
(map
(fn [force datum]
(if ((:close-enough? force) distance)
((:accumulator force) guest other distance datum)
datum))
forces data))))))
(defn- mingle [guest peers]
(apply-forces guest
(calc-forces guest peers
ideal-distance
)))
(defn- update-location [guest]
(let [new-velocity (->
(:velocity guest)
(add (:acceleration guest))
(mult friction)
(limit (:max-speed guest)))
new-location (->
(:location guest)
(add new-velocity))]
(assoc guest
:location new-location
:velocity new-velocity
:acceleration zero-vec)))
(defn- bounds [value lower-limit upper-limit]
(cond
(< value lower-limit) upper-limit
(> value upper-limit) lower-limit
:else value))
(defn- wrap-around [guest w h r]
(let [[x y] (:location guest)
new-x (bounds x (- r) (+ w r))
new-y (bounds y (- r) (+ h r))]
(if (and (= x new-x) (= y new-y))
guest
(assoc guest :location (make-vector new-x new-y)))))
(defn step [w h r]
(fn [guest peers]
(->
guest
(mingle peers)
(update-location)
(wrap-around w h r))))
(ns party-planner.vector)
(defn add [[x1 y1] [x2 y2]]
[(+ x1 x2) (+ y1 y2)])
(defn sub [[x1 y1] [x2 y2]]
[(- x1 x2) (- y1 y2)])
(defn mult [[x y] n]
[(* x n) (* y n)])
(defn div [[x y] n]
[(/ x n) (/ y n)])
(defn dot [[x1 y1] [x2 y2]]
(+
(* x1 x2)
(* y1 y2)))
(defn mag-sq [xy]
(dot xy xy))
(defn mag [xy]
(Math/sqrt (mag-sq xy)))
(defn normalize [xy]
(let [m (mag xy)]
(if (and (not= m 0) (not= m 1))
(div xy m)
xy)))
(defn dist [[x1 y1] [x2 y2]]
(let [dx (- x1 x2)
dy (- y1 y2)]
(Math/sqrt
(+
(* dx dx)
(* dy dy)))))
(defn limit [xy max]
(if (> (mag-sq xy) (* max max))
(-> xy normalize (mult max))
xy))
(defn rotate [[x y] theta]
[
(- (* x (Math/cos theta))
(* y (Math/sin theta)))
(+ (* x (Math/sin theta))
(* y (Math/cos theta)))])
(defn heading [[x y]]
(- (Math/atan2 (- y) x)))
(defn rand-vector [n]
(let [theta (* 2 Math/PI (rand))]
[(* n (Math/sin theta)) (* n (Math/cos theta))]))
(defn make-vector [x y]
[x y])
(defn add-all [vectors]
(loop [vs vectors
accum-x 0
accum-y 0]
(if (empty? vs)
[accum-x accum-y]
(let [[x y] (first vs)]
(recur
(rest vs)
(+ accum-x x)
(+ accum-y y))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment