travelling-salesman.cljs
(ns enchilada.travelling-salesman
(:require
[cljs.core.async :as async]
[enchilada :refer [canvas ctx canvas-size]]
[enchilada.travelling-salesman.datasets :as data]
[big-bang.core :refer [big-bang]]
[big-bang.package :refer [make-package]]
[jayq.core :refer [show]]
[monet.canvas :refer [clear-rect fill-style fill fill-rect circle
stroke-style stroke-width stroke-join stroke
begin-path move-to line-to close-path
text]]))
(defn interpolate-line [from to n]
(let [from (vec from)
size (count from)
step (fn [f] (fn [a b] (double (/ (- (f b) (f a)) n))))
delta (mapv (juxt (step first) (step second)) from to)]
(fn [idx t]
(when (and (< idx size) (<= t n))
(let [[dx dy] (nth delta idx)
[x y] (nth from idx)]
[(+ x (* dx t)) (+ y (* dy t))])))))
(def background
(let [[w h] (canvas-size)]
{:x 0 :y 0 :w w :h h}))
(defn update-clock [event world-state]
(update-in world-state [:t] inc))
(defn create-new-interpolator [event world-state]
(let [[from to] (event :lines)]
(->
world-state
(update-in [:generation] inc)
(assoc
:line to
:interpolator (interpolate-line from to 35)
:t 0))))
(defn draw-polyline [ctx interpolator t]
(let [[x y] (interpolator 0 t)]
(->
ctx
(begin-path)
(move-to x y)))
(loop [i 1]
(when-let [[x y] (interpolator i t)]
(line-to ctx x y)
(recur (inc i))))
(->
ctx
(close-path)
(stroke)))
(defn draw-circles [ctx interpolator t]
(begin-path ctx)
(loop [i 0]
(when-let [[x y] (interpolator i t)]
(-> ctx (circle {:x x :y y :r 5}) (fill))
(recur (inc i))))
ctx)
(defn draw-labels [ctx line]
(fill-style ctx :#333)
(doseq [ [x y name] line]
(when name
(text ctx {:x (+ x 10) :y y :text name})))
ctx)
(defn draw-stats [ctx line generation]
(->
ctx
(fill-style :#333)
(text {:x 700 :y 20 :text (str "Generation: " generation) })
(text {:x 700 :y 35 :text (str "Distance: " (int (calc-score line))) })))
(defn render [{:keys [interpolator line generation t] :as world-state}]
(when (interpolator 0 t)
(->
ctx
(clear-rect background)
(fill-style :red)
(stroke-style :red)
(stroke-width 3)
(stroke-join :round)
(draw-polyline interpolator t)
(draw-circles interpolator t)
(draw-labels line)
(draw-stats line generation))))
(defn send-lines [event {:keys [lines] :as world-state}]
(make-package
(update-in world-state [:lines] next)
{:lines (take 2 lines)}))
(defn distance [[ax ay] [bx by]]
(let [dx (- ax bx)
dy (- ay by)]
(Math/sqrt (+ (* dx dx) (* dy dy)))))
(defn calc-score [gene]
(->>
(partition 2 1 (conj gene (first gene)))
(map #(apply distance %))
(reduce +)))
(defn reproduce [copies gene]
(repeat copies gene))
(defn swap [gene i j]
(assoc gene
j (nth gene i)
i (nth gene j)))
(defn mutate [probability gene]
(let [n (count gene)]
(loop [i 0
g (vec gene)]
(if (>= i n)
g
(recur
(inc i)
(if (<= (rand) probability)
(swap g i (rand-int n))
g))))))
(defn evolve [genes decay-fn t]
(let [mutations (->>
(mapcat reproduce [80 20 10 5 5 2 2 2 2 2] genes)
(map (partial mutate (decay-fn t)))
(concat genes))
scores (map #(vector (calc-score %) %) mutations)
fittest (map second (sort-by first scores))]
(cons
(first fittest)
(lazy-seq
(evolve
(take 10 fittest)
decay-fn
(inc t))))))
(defn exponential-decay [start baseline scaling-time]
(fn [t]
(+ baseline (* (- start baseline) (Math/exp (- (/ t scaling-time)))))))
(def initial-state
(let [dataset (rand-nth [
data/uk-cities
data/west-german-cities
data/us-states
(data/make-rand-points 30)
(data/make-circle 400 300 20 200)
(data/make-donut 400 300 15 170 280)])]
{:lines (evolve
[(vec dataset)]
(exponential-decay 0.25 0.05 10)
0)}))
(defn start []
(show canvas)
(let [chan (async/chan)]
;;; INTERPOLATOR:
; this big-bang is responsible for rendering tween lines
(big-bang
:initial-state {:generation 0 :line nil :interpolator (constantly nil)}
:on-tick update-clock
:receive-channel chan
:on-receive create-new-interpolator
:to-draw render)
;;; GENERATOR:
; this big-bang evolves the lines, and sends pairs to the INTERPOLATOR
(big-bang
:initial-state initial-state
:on-tick send-lines
:send-channel chan
:tick-rate 800)))
(start) tsp-datasets.cljs
(ns enchilada.travelling-salesman.datasets
(:require
[enchilada :refer [canvas-size]]))
(def dimensions
(let [[width height] (canvas-size)]
{:x 0 :y 0 :w width :h height}))
; US, UK & German city data derived from:
; http://people.sc.fsu.edu/~jburkardt/datasets/cities/cities.html
(defn random-point []
[(+ 20 (rand-int 760)) (+ 20 (rand-int 560))])
(defn make-rand-points [n]
(vec (repeatedly n random-point)))
(defn make-circle [x y n r]
(shuffle
(for [i (range n)]
(let [theta (/ (* i 2 Math/PI) n)]
[(int (+ x (* r (Math/sin theta)))) (int (+ y (* r (Math/cos theta))))]))))
(defn make-donut [x y n r1 r2]
(shuffle
(concat
(make-circle x y n r1)
(make-circle x y n r2))))
; TODO: try transducers
(defn translate [dx dy coll]
(map (fn [[x y name]] [(+ x dx) (+ y dy) name]) coll))
(defn scale [sx sy coll]
(mapv (fn [[x y name]] [(* x sx) (* y sy) name]) coll))
(def west-german-cities
(shuffle
(translate 300 400
(scale 2 -2
[[-57 28 "Aachen"]
[ 54 -65 "Augsburg"]
[ 46 79 "Braunschweig"]
[ 8 111 "Bremen"]
[-36 52 "Essen"]
[-22 -76 "Freiburg"]
[ 34 129 "Hamburg"]
[ 74 6 "Hof"]
[ -6 -41 "Karlsruhe"]
[ 21 45 "Kassel"]
[ 37 155 "Kiel"]
[-38 35 "Koeln"]
[ -5 -24 "Mannheim"]
[ 70 -74 "Muenchen"]
[ 59 -26 "Nuernberg"]
[114 -56 "Passau"]
[ 83 -41 "Regensburg"]
[-40 -28 "Saarbruecken"]
[ 21 -12 "Wuerzburg"]
[ 0 71 "Bielefeld"]
[ 50 140 "Luebeck"]
[-20 70 "Muenster"]]))))
(def uk-cities
(shuffle
(translate 0 650
(scale 0.0008 -0.0008
[[270576 281646 "Aberystwyth"]
[529576 105146 "Brighton"]
[323576 672146 "Edinburgh"]
[459076 449646 "York"]
[355576 429146 "Preston"]
[406826 286646 "Birmingham"]
[621826 310146 "Norwich"]
[318326 179646 "Cardiff"]
[358826 173646 "Bristol"]
[294076 91646 "Exeter"]
[260072 665518 "Glasgow"]
[209809 772887 "Inverness"]
[335576 391146 "Liverpool"]
[532576 180864 "London"]
[425606 563641 "Newcastle"]
[455962 341397 "Nottingham"]
[457326 241146 "Oxford"]
[518576 298146 "Peterborough"]]))))
(def us-states ; minus Hawaii & Alaska (for 'logistical' reasons)
(shuffle
(translate 1500 1450
(scale 0.17 -0.42 ; stretched somewhat to fit 800x600 px
[[-5961.513053174005 2236.041995790761 "AL"]
[-7743.816805421991 2311.143387140668 "AZ"]
[-6379.680295493998 2400.107649091518 "AR"]
[-8392.976246048636 2664.025175599511 "CA"]
[-7253.950856881725 2745.804158594989 "CO"]
[-5021.665661504875 2885.918649422432 "CT"]
[-5218.571378956087 2705.918982955634 "DE"]
[-5822.883103442604 2104.087378276678 "FL"]
[-5830.983188276846 2332.669657971635 "GA"]
[-8031.517819952500 3013.520309123051 "ID"]
[-6194.452160039679 2748.850123533770 "IL"]
[-5952.431602606583 2749.381607390675 "IN"]
[-6468.796015143020 2873.753597507381 "IA"]
[-6611.764205311191 2697.494770355825 "KS"]
[-5863.673038451106 2639.266056784030 "KY"]
[-6297.394751448061 2104.521990010939 "LA"]
[-4820.477118340399 3062.564135916582 "ME"]
[-5285.898333341956 2692.861560524212 "MD"]
[-4907.692361717428 2918.269239880439 "MA"]
[-5841.810479017491 2952.699609861697 "MI"]
[-6432.391858388964 3105.850151831310 "MN"]
[-6232.912672886473 2233.171900048675 "MS"]
[-6369.879835434252 2665.223916295487 "MO"]
[-7740.582230045847 3219.568143135753 "MT"]
[-6679.847273561608 2819.784977174988 "NE"]
[-8274.473794501402 2705.851821969037 "NV"]
[-4943.734526281372 2986.321076890174 "NH"]
[-5165.325084707952 2779.147950873629 "NJ"]
[-7321.692799832930 2464.451052653001 "NM"]
[-5097.970699342989 2947.609263108960 "NY"]
[-5433.544921906798 2471.621040737659 "NC"]
[-6963.392322020205 3372.790406405869 "ND"]
[-5734.984918510500 2761.217902130590 "OH"]
[-6739.245293075994 2451.673744048398 "OK"]
[-8500.781583088507 3104.544865619558 "OR"]
[-5311.771619759177 2782.467859396325 "PA"]
[-4934.959722276215 2889.826009290865 "RI"]
[-5599.167231449393 2349.252617625462 "SC"]
[-6932.808784104642 3065.634125418163 "SD"]
[-5996.398210823769 2498.844732836025 "TN"]
[-6754.101275673204 2091.295490486712 "TX"]
[-7731.295150778718 2815.973107515895 "UT"]
[-5014.406470916412 3058.615664127341 "VT"]
[-5352.150228272597 2593.851272519408 "VA"]
[-8491.378906773456 3250.427165468564 "WA"]
[-5640.506753379088 2649.784006231465 "WV"]
[-6176.077618882252 2976.276570940856 "WI"]
[-7241.366808852755 2842.979010077474 "WY"]]))))