Last active
November 29, 2019 03:17
-
-
Save wiseman/5eb4ef4114c73f277931 to your computer and use it in GitHub Desktop.
Party Planner
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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)))) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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