The TSP ('travelling salesman problem') is a popular demonstration of an NP-hard problem in Computer Science: Given a list of cities and the distances between each pair of cities, what is the shortest possible route that visits each city exactly once and returns to the origin city? This implementation uses an evolutionary _cumulative-selection_ …

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"]]))))