Party Planner

party-planner.cljs

(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)

rules.cljs

(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))))

vector.cljs

(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))))))