(ns graphito.core
  (:require [clojure.browser.repl :as repl]))

;; (defonce conn
;;   (repl/connect "http://localhost:9000/repl"))

;; Debug

(enable-console-print!)

(defn p [message f & args]
  (let [ret (apply f args)]
    (println message (apply f args))
    ret))

;; External library modules

(def d3 js/d3)
(def rx-observable (.-Observable js/Rx))

;; Constants

(def world-width 1280)
(def world-height 800)

(def update-interval-ms 15)

(def swipe-damping-factor 1)
(def min-slide-speed-sq 16)

; A factor of 1 is an ellipse fitting the bounds of the window. Higher factors
; expand the visualization linearly.
(def displacement-factor 1)

(def max-radius 32)
(def min-radius 2)
(def edge-buffer (+ min-radius 3))

;; SVG setup

(defn disable-touchmove! [container]
  (.on container "touchmove" #(-> d3 .-event .preventDefault)))

(defn add-background! [svg width height]
  (-> svg
      (.append "rect")
      (.attr "width" width)
      (.attr "height" height)
      (.attr "fill" "#ccc")
      (.attr "stroke" 0)))

(defn setup-svg! [selector width height]
  (let [container (.select d3 selector)
        svg (-> container
                (.append "svg")
                (.attr "width" width)
                (.attr "height" height))]
    (disable-touchmove! container)
    (add-background! svg width height)
    svg))

;; Vector math

(defn math-vec [x y] {:x x :y y})

(def sqrt (.-sqrt js/Math))

(defn vec-length-sq [v]
  (let [{:keys [x y]} v]
    (+ (* x x) (* y y))))

(def vec-length (comp sqrt vec-length-sq))

(defn add-vec [v1 v2]
  (merge-with + v1 v2))

(defn subtract-vec [v1 v2]
  (merge-with - v1 v2))

(defn scalar-multiply [v c]
  (if (= c 1)
    v
    (math-vec (* c (:x v)) (* c (:y v)))))

(defn neg-vec [v]
  (scalar-multiply v -1))

(defn vec-with-length [v l]
  (scalar-multiply v (/ l (vec-length v))))

(def vec-distance (comp vec-length subtract-vec))

(defn vec-clamp-to-bounds [v bounds]
  (let [ratios (merge-with (comp js/Math.abs /) bounds v)
        max-ratio (min 1 (:x ratios) (:y ratios))]
    (scalar-multiply v max-ratio)))

;; D3 magic

(defn scaled-distance-from-camera
  "Returns the distance of the given point from the camera, scaled so that
  points which would be at the corner of the screen are at distance 1"
  [state pos]
  (let [{:keys [camera-pos view-size]} state
        corner-distance (/ (vec-length view-size) 2)]
    (/ (vec-distance (:camera-pos state) pos) corner-distance)))

(defn elliptic-distance-from-camera [state pos]
  "An alternate method of computing distance, currently unused."
  (let [{:keys [view-size camera-pos]} state
        rx (/ (:x view-size) 2)
        ry (/ (:y view-size) 2)
        sq (fn [x] (* x x))
        {:keys [x y]} (subtract-vec pos camera-pos)]
    (sqrt (+ (/ (sq x) (sq rx)) (/ (sq y) (sq ry))))))

(defn project-displacement [t]
  (cond
    (<= t 0.5) t
    (<= 0.5 t 1) (+ 0.5 (/ (- t 0.5) 2))
    (<= 1 t 1.5) (+ 0.75 (/ (- t 1) 4))
    (<= 1.5 t 2.5) (+ 0.875 (/ (- t 1.5) 8))
    (<= 2.5 t) 1))

(defn view-position [state pos]
  (let [{:keys [view-size camera-pos]} state
        view-center (scalar-multiply view-size 0.5)
        corner-distance (vec-length view-center)
        displacement (subtract-vec pos camera-pos)
        r (scaled-distance-from-camera state pos)
        projected-r (project-displacement r)]
      (add-vec view-center
            (vec-clamp-to-bounds (scalar-multiply displacement (/ projected-r r)) view-center))))

(defn project-radius [t]
  (+ min-radius (* (- max-radius min-radius)
                   (min 1 (/ 1 (.pow js/Math 2 (* 2 (- t 0.25))))))))

(defn view-radius [state pos]
  (let [r (scaled-distance-from-camera state pos)]
    (project-radius r)))

(defn sync-graph! [state]
  (let [{:keys [svg nodes]} state
        _view-position (fn [d] (view-position state (:pos d)))
        view-x (comp :x _view-position)
        view-y (comp :y _view-position)
        _view-radius (fn [d] (view-radius state (:pos d)))]
    (-> svg
        (.selectAll ".node")
        (.data (apply array nodes))
        (.attr "cx" view-x)
        (.attr "cy" view-y)
        (.attr "r" _view-radius)
        .enter
        (.append "circle")
        (.attr "class" "node")
        (.attr "cx" view-x)
        (.attr "cy" view-y)
        (.attr "r" _view-radius))))

;; State management

(defn initial-state [svg width height]
  {:svg svg
   :view-size (math-vec width height)
   :camera-pos (math-vec 0 0)
   :nodes []})

(defn swap-state! [current-state f & args]
  (apply swap! current-state f args)
  (sync-graph! @current-state))

(defn update-state! [current-state k f & args]
  (apply swap! current-state update k f args)
  (sync-graph! @current-state))

(defn move-camera! [current-state d]
  (update-state! current-state :camera-pos add-vec d))

;; Layout

(defn get-force-layout []
  (-> d3 .-layout .force
      (.charge -240)
      (.linkDistance 40)
      (.size (array world-width world-height))))

(defn do-layout! [data]
  (let [n (-> data .-nodes .-length)
        force-layout (get-force-layout)]
    ; Initialize the positions deterministically, for better results
    (-> data .-nodes
        (.forEach (fn [d i]
                    (let [val (* i (/ world-width n))]
                      (aset d "x" val)
                      (aset d "y" val)))))
    (-> force-layout
        (.nodes (.-nodes data))
        (.links (.-links data))
        .start)
    (dotimes [_ n]
      (.tick force-layout))
    (.stop force-layout)
    ; Center the nodes in the middle
    (let [sum-x (->> data .-nodes js->clj (map #(% "x")) (apply +))
          sum-y (->> data .-nodes js->clj (map #(% "y")) (apply +))
          avg-x (/ sum-x n)
          avg-y (/ sum-y n)
          ; Nodes are too close together, but the graph has good shape.
          ; Expand everything.
          scale-hack 8]
      (-> data .-nodes
          (.forEach (fn [d]
                      (aset d "x" (* scale-hack (- (.-x d) avg-x)))
                      (aset d "y" (* scale-hack (- (.-y d) avg-y)))))))
    data))

;; JSON loading and parsing

(defn node [title x y]
  {:title title
   :pos (math-vec x y)})

(defn load-nodes [json-file callback]
  (.json d3 json-file
         (fn [data]
           (do-layout! data)
           (let [raw-nodes (js->clj (.-nodes data) :keywordize-keys true)
                 nodes (map (fn [raw-node]
                              (node (:name raw-node)
                                    (:x raw-node)
                                    (:y raw-node))) raw-nodes)]
             (callback nodes)))))

;; Reactive

(def tick-observable (js/Rx.Observable.interval update-interval-ms))

;; Arrow keys

(def key-down-observable (.fromEvent rx-observable js/document "keydown"))
(def key-up-observable (.fromEvent rx-observable js/document "keyup"))
(def keys-observable
  "An observable of what keys are currently pressed"
  (-> key-down-observable (.merge key-up-observable)
      (.scan (fn [ks, e]
               (case (.-type e)
                 "keydown" (conj ks (.-keyCode e))
                 "keyup" (disj ks (.-keyCode e))))
             #{})
      (.distinctUntilChanged)))

(def arrow-codes {37 :left, 38 :up, 39 :right, 40 :down
                  65 :left, 87 :up, 68 :right, 83 :down})

(def arrow-keys-observable
  (.map keys-observable #(->> % (map arrow-codes) (filter (comp not nil?)) (into #{}))))

(defn move-camera-on-arrow-keys! [current-state]
  (-> arrow-keys-observable
      (.flatMapLatest (fn [arrows] (if (empty? arrows)
                                     (.empty rx-observable)
                                     (-> tick-observable (.map (constantly arrows))))))
      (.subscribe
        (fn [arrows]
          (let [dx (+ (if (arrows :left) -10 0) (if (arrows :right) 10 0))
                dy (+ (if (arrows :up) -10 0) (if (arrows :down) 10 0))]
            (move-camera! current-state (math-vec dx dy)))))))

;; Gestures

(defn hammer-manager [svg]
  (let [manager (js/Hammer.Manager. (.node svg))]
    (.add manager (js/Hammer.Pan.))
    (-> manager (.add (js/Hammer.Swipe.))
        (.recognizeWith (.get manager "pan")))
    (-> manager (.add (js/Hammer.Pinch.))
        (.recognizeWith (.get manager "pan")))
    manager))

(defn gesture-observable [manager svg gesture]
  (.create rx-observable
           (fn [observer] (.on manager gesture #(.onNext observer %)))))

;; Gestures - pan

(defn pan-observable [manager svg]
  (gesture-observable manager svg "panstart panmove"))

(defn pan-deltas-observable [manager svg]
  (-> (pan-observable manager svg)
      (.bufferWithCount 2 1)
      (.map (fn [es] (let [[e1 e2] es
                           e1-center (.-center e1)
                           e2-center (.-center e2)]
                       (if (= (.-type e2) "panstart")
                         (math-vec 0 0)
                         (math-vec (- (.-x e1-center) (.-x e2-center))
                                   (- (.-y e1-center) (.-y e2-center)))))))))

(defn move-camera-on-pan! [manager current-state]
  (.subscribe
    (pan-deltas-observable manager (:svg @current-state))
    (partial move-camera! current-state)))

;; Gestures - swipe

(defn swipe-observable
  "A stream of velocity vectors, one per swipe."
  [manager svg]
  (.map (gesture-observable manager svg "swipe")
        (fn [e] {:vx (.-velocityX e), :vy (.-velocityY e)})))

(defn scroll-end-observable [svg]
  (let [elem (.node svg)]
    (-> rx-observable (.fromEvent elem "mousedown")
        (.merge (-> rx-observable (.fromEvent elem "touchstart")))
        (.map (constantly :scroll-end)))))

(defn dampen [v]
  (let [length (vec-length v)]
    (vec-with-length v (- length swipe-damping-factor))))

(defn swipe-displacements-observable [manager svg]
  (let [swipes (swipe-observable manager svg)
        scroll-ends (scroll-end-observable svg)
        actions (.merge swipes scroll-ends)]
    (.flatMapLatest
      actions
      (fn [a]
        (if (= a :scroll-end)
          (.empty rx-observable)
          (let [{:keys [vx vy]} a]
            (.generateWithRelativeTime rx-observable
                                       (math-vec (* update-interval-ms (or vx 0))
                                                 (* update-interval-ms (or vy 0)))
                                       (fn [v] (> (vec-length-sq v) min-slide-speed-sq))
                                       dampen
                                       identity
                                       (constantly update-interval-ms))))))))

(defn move-camera-on-swipe! [manager current-state]
  (.subscribe
    (swipe-displacements-observable manager (:svg @current-state))
    (partial move-camera! current-state)))

;; Gestures - pinch

(defn pinch-observable
  "Returns a stream of the scale."
  [manager svg]
  (.map (gesture-observable manager svg "pinchmove")
        #(.-scale %)))

(defn zoom-out-on-pinch! [manager current-state]
  (-> (pinch-observable manager (:svg @current-state))
      (.filter #(< % 0.5))
      (.subscribe #(js/alert "TODO: zoom out"))))

;; Exported function to do magic

(defn ^:export inhabit [selector]
  (let [element (-> d3 (.select selector) .node)
        width (.-clientWidth element)
        height (.-clientHeight element)
        svg (setup-svg! selector width height)
        current-state (atom (initial-state svg width height))
        gesture-manager (hammer-manager svg)]
    (sync-graph! @current-state)
    (load-nodes "miserables.json" (fn [nodes]
                                    (swap-state! current-state assoc :nodes nodes)))
    (move-camera-on-arrow-keys! current-state)
    (move-camera-on-pan! gesture-manager current-state)
    (move-camera-on-swipe! gesture-manager current-state)
    (zoom-out-on-pinch! gesture-manager current-state)))

(ns graphito.core
  (:require [clojure.browser.repl :as repl]))

;; (defonce conn
;;   (repl/connect "http://localhost:9000/repl"))

;; Debug

(enable-console-print!)

(defn p [message f & args]
  (let [ret (apply f args)]
    (println message (apply f args))
    ret))

;; External library modules

(def d3 js/d3)
(def rx-observable (.-Observable js/Rx))

;; Constants

(def world-width 1280)
(def world-height 800)

(def update-interval-ms 15)

(def swipe-damping-factor 1)
(def min-slide-speed-sq 16)

; A factor of 1 is an ellipse fitting the bounds of the window. Higher factors
; expand the visualization linearly.
(def displacement-factor 1)

(def max-radius 32)
(def min-radius 2)
(def edge-buffer (+ min-radius 3))

;; SVG setup

(defn disable-touchmove! [container]
  (.on container "touchmove" #(-> d3 .-event .preventDefault)))

(defn add-background! [svg width height]
  (-> svg
      (.append "rect")
      (.attr "width" width)
      (.attr "height" height)
      (.attr "fill" "#ccc")
      (.attr "stroke" 0)))

(defn setup-svg! [selector width height]
  (let [container (.select d3 selector)
        svg (-> container
                (.append "svg")
                (.attr "width" width)
                (.attr "height" height))]
    (disable-touchmove! container)
    (add-background! svg width height)
    svg))

;; Vector math

(defn math-vec [x y] {:x x :y y})

(def sqrt (.-sqrt js/Math))

(defn vec-length-sq [v]
  (let [{:keys [x y]} v]
    (+ (* x x) (* y y))))

(def vec-length (comp sqrt vec-length-sq))

(defn add-vec [v1 v2]
  (merge-with + v1 v2))

(defn subtract-vec [v1 v2]
  (merge-with - v1 v2))

(defn scalar-multiply [v c]
  (if (= c 1)
    v
    (math-vec (* c (:x v)) (* c (:y v)))))

(defn neg-vec [v]
  (scalar-multiply v -1))

(defn vec-with-length [v l]
  (scalar-multiply v (/ l (vec-length v))))

(def vec-distance (comp vec-length subtract-vec))

(defn vec-clamp-to-bounds [v bounds]
  (let [ratios (merge-with (comp js/Math.abs /) bounds v)
        max-ratio (min 1 (:x ratios) (:y ratios))]
    (scalar-multiply v max-ratio)))

;; D3 magic

(defn scaled-distance-from-camera
  "Returns the distance of the given point from the camera, scaled so that
  points which would be at the corner of the screen are at distance 1"
  [state pos]
  (let [{:keys [camera-pos view-size]} state
        corner-distance (/ (vec-length view-size) 2)]
    (/ (vec-distance (:camera-pos state) pos) corner-distance)))

(defn elliptic-distance-from-camera [state pos]
  "An alternate method of computing distance, currently unused."
  (let [{:keys [view-size camera-pos]} state
        rx (/ (:x view-size) 2)
        ry (/ (:y view-size) 2)
        sq (fn [x] (* x x))
        {:keys [x y]} (subtract-vec pos camera-pos)]
    (sqrt (+ (/ (sq x) (sq rx)) (/ (sq y) (sq ry))))))

(defn project-displacement [t]
  (cond
    (<= t 0.5) t
    (<= 0.5 t 1) (+ 0.5 (/ (- t 0.5) 2))
    (<= 1 t 1.5) (+ 0.75 (/ (- t 1) 4))
    (<= 1.5 t 2.5) (+ 0.875 (/ (- t 1.5) 8))
    (<= 2.5 t) 1))

(defn view-position [state pos]
  (let [{:keys [view-size camera-pos]} state
        view-center (scalar-multiply view-size 0.5)
        corner-distance (vec-length view-center)
        displacement (subtract-vec pos camera-pos)
        r (scaled-distance-from-camera state pos)
        projected-r (project-displacement r)]
    (add-vec view-center
             (vec-clamp-to-bounds (scalar-multiply displacement (/ projected-r r)) view-center))))

(defn project-radius [t]
  (+ min-radius (* (- max-radius min-radius)
                   (min 1 (/ 1 (.pow js/Math 2 (* 2 (- t 0.25))))))))

(defn view-radius [state pos]
  (let [r (scaled-distance-from-camera state pos)]
    (project-radius r)))

(defn sync-graph! [state]
  (let [{:keys [svg nodes links]} state
        _view-position (fn [d] (view-position state (:pos d)))
        view-x (comp :x _view-position)
        view-y (comp :y _view-position)
        _view-radius (fn [d] (view-radius state (:pos d)))]
    (-> svg (.selectAll ".link")
        (.data (apply array links))
        (.attr "x1" (fn [link] (view-x (nodes (:source link)))))
        (.attr "y1" (fn [link] (view-y (nodes (:source link)))))
        (.attr "x2" (fn [link] (view-x (nodes (:target link)))))
        (.attr "y2" (fn [link] (view-y (nodes (:target link)))))
        .enter
        (.append "line")
        (.attr "class" "link")
        (.attr "x1" (fn [link] (view-x (nodes (:source link)))))
        (.attr "y1" (fn [link] (view-y (nodes (:source link)))))
        (.attr "x2" (fn [link] (view-x (nodes (:target link)))))
        (.attr "y2" (fn [link] (view-y (nodes (:target link)))))
        (.style "stroke" "black")
        (.style "stroke-width" 3))
    (-> svg (.selectAll ".node")
        (.data (apply array nodes))
        (.attr "cx" view-x)
        (.attr "cy" view-y)
        (.attr "r" _view-radius)
        .enter
        (.append "circle")
        (.attr "class" "node")
        (.attr "cx" view-x)
        (.attr "cy" view-y)
        (.attr "r" _view-radius))))

;; State management

(defn initial-state [svg width height]
  {:svg svg
   :view-size (math-vec width height)
   :camera-pos (math-vec 0 0)
   :nodes []
   :edges []})

(defn swap-state! [current-state f & args]
  (apply swap! current-state f args)
  (sync-graph! @current-state))

(defn update-state! [current-state k f & args]
  (apply swap! current-state update k f args)
  (sync-graph! @current-state))

(defn move-camera! [current-state d]
  (update-state! current-state :camera-pos add-vec d))

;; Layout

(defn get-force-layout []
  (-> d3 .-layout .force
      (.charge -240)
      (.linkDistance 40)
      (.size (array world-width world-height))))

(defn do-layout! [data]
  (let [n (-> data .-nodes .-length)
        force-layout (get-force-layout)]
    ; Initialize the positions deterministically, for better results
    (-> data .-nodes
        (.forEach (fn [d i]
                    (let [val (* i (/ world-width n))]
                      (aset d "x" val)
                      (aset d "y" val)))))
    (-> force-layout
        (.nodes (.-nodes data))
        (.links (.-links data))
        .start)
    (dotimes [_ n]
      (.tick force-layout))
    (.stop force-layout)
    ; Center the nodes in the middle
    (let [sum-x (->> data .-nodes js->clj (map #(% "x")) (apply +))
          sum-y (->> data .-nodes js->clj (map #(% "y")) (apply +))
          avg-x (/ sum-x n)
          avg-y (/ sum-y n)
          ; Nodes are too close together, but the graph has good shape.
          ; Expand everything.
          scale-hack 8]
      (-> data .-nodes
          (.forEach (fn [d]
                      (aset d "x" (* scale-hack (- (.-x d) avg-x)))
                      (aset d "y" (* scale-hack (- (.-y d) avg-y)))))))
    data))

;; JSON loading and parsing

(defn node [title x y]
  {:title title
   :pos (math-vec x y)})

(defn link
  "Source and target are indexes into the list of nodes."
  [source target]
  {:source source :target target})

(defn load-graph [json-file callback]
  (.json d3 json-file
         (fn [raw-data]
           ;; Running do-layout! modifies the link data to contain full nodes
           ;;  rather than indices. Hence this ugly ordering.
           (let [data-links (js->clj (aget raw-data "links"))
                 links (mapv (fn [data-link]
                               (link (data-link "source") (data-link "target")))
                             data-links)]
             (do-layout! raw-data)
             (let [data-nodes (js->clj (aget raw-data "nodes"))
                   nodes (mapv (fn [data-node]
                                 (node (data-node "name")
                                       (data-node "x")
                                       (data-node "y"))) data-nodes)]
               (callback {:nodes nodes :links links}))))))

;; Reactive

(def tick-observable (js/Rx.Observable.interval update-interval-ms))

;; Arrow keys

(def key-down-observable (.fromEvent rx-observable js/document "keydown"))
(def key-up-observable (.fromEvent rx-observable js/document "keyup"))
(def keys-observable
  "An observable of what keys are currently pressed"
  (-> key-down-observable (.merge key-up-observable)
      (.scan (fn [ks, e]
               (case (.-type e)
                 "keydown" (conj ks (.-keyCode e))
                 "keyup" (disj ks (.-keyCode e))))
             #{})
      (.distinctUntilChanged)))

(def arrow-codes {37 :left, 38 :up, 39 :right, 40 :down
                  65 :left, 87 :up, 68 :right, 83 :down})

(def arrow-keys-observable
  (.map keys-observable #(->> % (map arrow-codes) (filter (comp not nil?)) (into #{}))))

(defn move-camera-on-arrow-keys! [current-state]
  (-> arrow-keys-observable
      (.flatMapLatest (fn [arrows] (if (empty? arrows)
                                     (.empty rx-observable)
                                     (-> tick-observable (.map (constantly arrows))))))
      (.subscribe
        (fn [arrows]
          (let [dx (+ (if (arrows :left) -10 0) (if (arrows :right) 10 0))
                dy (+ (if (arrows :up) -10 0) (if (arrows :down) 10 0))]
            (move-camera! current-state (math-vec dx dy)))))))

;; Gestures

(defn hammer-manager [svg]
  (let [manager (js/Hammer.Manager. (.node svg))]
    (.add manager (js/Hammer.Pan.))
    (-> manager (.add (js/Hammer.Swipe.))
        (.recognizeWith (.get manager "pan")))
    (-> manager (.add (js/Hammer.Pinch.))
        (.recognizeWith (.get manager "pan")))
    manager))

(defn gesture-observable [manager svg gesture]
  (.create rx-observable
           (fn [observer] (.on manager gesture #(.onNext observer %)))))

;; Gestures - pan

(defn pan-observable [manager svg]
  (gesture-observable manager svg "panstart panmove"))

(defn pan-deltas-observable [manager svg]
  (-> (pan-observable manager svg)
      (.bufferWithCount 2 1)
      (.map (fn [es] (let [[e1 e2] es
                           e1-center (.-center e1)
                           e2-center (.-center e2)]
                       (if (= (.-type e2) "panstart")
                         (math-vec 0 0)
                         (math-vec (- (.-x e1-center) (.-x e2-center))
                                   (- (.-y e1-center) (.-y e2-center)))))))))

(defn move-camera-on-pan! [manager current-state]
  (.subscribe
    (pan-deltas-observable manager (:svg @current-state))
    (partial move-camera! current-state)))

;; Gestures - swipe

(defn swipe-observable
  "A stream of velocity vectors, one per swipe."
  [manager svg]
  (.map (gesture-observable manager svg "swipe")
        (fn [e] {:vx (.-velocityX e), :vy (.-velocityY e)})))

(defn scroll-end-observable [svg]
  (let [elem (.node svg)]
    (-> rx-observable (.fromEvent elem "mousedown")
        (.merge (-> rx-observable (.fromEvent elem "touchstart")))
        (.map (constantly :scroll-end)))))

(defn dampen [v]
  (let [length (vec-length v)]
    (vec-with-length v (- length swipe-damping-factor))))

(defn swipe-displacements-observable [manager svg]
  (let [swipes (swipe-observable manager svg)
        scroll-ends (scroll-end-observable svg)
        actions (.merge swipes scroll-ends)]
    (.flatMapLatest
      actions
      (fn [a]
        (if (= a :scroll-end)
          (.empty rx-observable)
          (let [{:keys [vx vy]} a]
            (.generateWithRelativeTime rx-observable
                                       (math-vec (* update-interval-ms (or vx 0))
                                                 (* update-interval-ms (or vy 0)))
                                       (fn [v] (> (vec-length-sq v) min-slide-speed-sq))
                                       dampen
                                       identity
                                       (constantly update-interval-ms))))))))

(defn move-camera-on-swipe! [manager current-state]
  (.subscribe
    (swipe-displacements-observable manager (:svg @current-state))
    (partial move-camera! current-state)))

;; Gestures - pinch

(defn pinch-observable
  "Returns a stream of the scale."
  [manager svg]
  (.map (gesture-observable manager svg "pinchmove")
        #(.-scale %)))

(defn zoom-out-on-pinch! [manager current-state]
  (-> (pinch-observable manager (:svg @current-state))
      (.filter #(< % 0.5))
      (.subscribe #(js/alert "TODO: zoom out"))))

;; Exported function to do magic

(defn ^:export inhabit [selector]
  (let [element (-> d3 (.select selector) .node)
        width (.-clientWidth element)
        height (.-clientHeight element)
        svg (setup-svg! selector width height)
        current-state (atom (initial-state svg width height))
        gesture-manager (hammer-manager svg)]
    (sync-graph! @current-state)
    (load-graph "miserables.json"
                (fn [graph]
                  (let [{:keys [nodes links]} graph]
                    (swap-state! current-state assoc :nodes nodes :links links))))
                (move-camera-on-arrow-keys! current-state)
                (move-camera-on-pan! gesture-manager current-state)
                (move-camera-on-swipe! gesture-manager current-state)
                (zoom-out-on-pinch! gesture-manager current-state)))

Add links, but performance is horrible

Add links, but performance is horrible

Will optimize repeated computations next.


(ns playmary.util
  (:require-macros [cljs.core.async.macros :refer [go]])
  (:require [goog.dom :as dom]
            [goog.events :as events]
            [cljs.core.async :refer [<! put! chan]]))

(enable-console-print!)

(defn dirr [o]
  (.log js/console o)
  o)

(defn printlnr [o]
  (println o)
  o)

(defn get-window-size []
  { :w (or (.-innerWidth js/window) (.-clientWidth (.-body js/document)))
    :h (or (.-innerHeight js/window) (.-clientHeight (.-body js/document)))})

(defn set-canvas-size! [canvas-id {w :w h :h}]
  (let [canvas (dom/getElement canvas-id)]
    (set! (. canvas -width) w)
    (set! (. canvas -height) h)))

(defn get-ctx [canvas-id]
  (.getContext (dom/getElement canvas-id) "2d"))

(def keyword->event-type
  {:keyup goog.events.EventType.KEYUP
   :keydown goog.events.EventType.KEYDOWN
   :keypress goog.events.EventType.KEYPRESS
   :click goog.events.EventType.CLICK
   :dblclick goog.events.EventType.DBLCLICK
   :mousedown goog.events.EventType.MOUSEDOWN
   :mouseup goog.events.EventType.MOUSEUP
   :mouseover goog.events.EventType.MOUSEOVER
   :mouseout goog.events.EventType.MOUSEOUT
   :mousemove goog.events.EventType.MOUSEMOVE
   :focus goog.events.EventType.FOCUS
   :blur goog.events.EventType.BLUR

   :touchstart goog.events.EventType.TOUCHSTART
   :touchmove goog.events.EventType.TOUCHMOVE
   :touchend goog.events.EventType.TOUCHEND
   :touchcancel goog.events.EventType.TOUCHCANCEL

   :dragstart goog.events.EventType.DRAGSTART
   :drag goog.events.EventType.DRAG
   :dragenter goog.events.EventType.DRAGENTER
   :dragover goog.events.EventType.DRAGOVER
   :dragleave goog.events.EventType.DRAGLEAVE
   :drop goog.events.EventType.DROP
   :dragent goog.events.EventType.DRAGEND

   :orientation-change "orientationchange"
   })

(defn listen
  ([el type] (listen el type nil))
  ([el type f] (listen el type f (chan)))
  ([el type f out]
    (events/listen el (keyword->event-type type)
      (fn [e] (when f (f e)) (put! out e)))
    out))

(ns playmary.util
  (:require-macros [cljs.core.async.macros :refer [go]])
  (:require [goog.dom :as dom]
            [goog.events :as events]
            [cljs.core.async :refer [<! put! chan]]))

(enable-console-print!)

(defn dirr [o]
  (.log js/console o)
  o)

(defn printlnr [o]
  (println o)
  o)

(defn get-window-size []
  { :w (or (.-innerWidth js/window) (.-clientWidth (.-body js/document)))
    :h (or (.-innerHeight js/window) (.-clientHeight (.-body js/document)))})

(defn set-canvas-size! [canvas-id {w :w h :h}]
  (let [canvas (dom/getElement canvas-id)]
    (set! (. canvas -width) w)
    (set! (. canvas -height) h)))

(defn get-ctx [canvas-id]
  (.getContext (dom/getElement canvas-id) "2d"))

(def keyword->event-type
  {:keyup goog.events.EventType.KEYUP
   :keydown goog.events.EventType.KEYDOWN
   :keypress goog.events.EventType.KEYPRESS
   :click goog.events.EventType.CLICK
   :dblclick goog.events.EventType.DBLCLICK
   :mousedown goog.events.EventType.MOUSEDOWN
   :mouseup goog.events.EventType.MOUSEUP
   :mouseover goog.events.EventType.MOUSEOVER
   :mouseout goog.events.EventType.MOUSEOUT
   :mousemove goog.events.EventType.MOUSEMOVE
   :focus goog.events.EventType.FOCUS
   :blur goog.events.EventType.BLUR

   :touchstart goog.events.EventType.TOUCHSTART
   :touchmove goog.events.EventType.TOUCHMOVE
   :touchend goog.events.EventType.TOUCHEND
   :touchcancel goog.events.EventType.TOUCHCANCEL

   :dragstart goog.events.EventType.DRAGSTART
   :drag goog.events.EventType.DRAG
   :dragenter goog.events.EventType.DRAGENTER
   :dragover goog.events.EventType.DRAGOVER
   :dragleave goog.events.EventType.DRAGLEAVE
   :drop goog.events.EventType.DROP
   :dragend goog.events.EventType.DRAGEND

   :orientation-change "orientationchange"})

(defn listen
  ([el type] (listen el type nil))
  ([el type f] (listen el type f (chan)))
  ([el type f out]
    (events/listen el (keyword->event-type type)
      (fn [e] (when f (f e)) (put! out e)))
    out))

Fix typo in :dragend event keyword

Fix typo in :dragend event keyword


(ns postal.frames
  "A frame types definition.")

(defrecord Frame [command headers body])

(defn frame
  "A generic frame constructor."
  ([command headers]
   (frame command headers ""))
  ([command headers body]
   (Frame. command headers body)))

(defn query
  "A QUERY frame constructor."
  ([headers]
   (query headers ""))
  ([headers body]
   (frame :query headers body)))

(defn novelty
  "A NOVELTY frame constructor."
  ([headers]
   (novelty headers ""))
  ([headers body]
   (frame :novelty headers body)))

(defn subscribe
  "A SUBSCRIBE frame constructor."
  ([headers]
   (subscribe headers ""))
  ([headers body]
   (frame :subscribe headers body)))

(defn unsubscribe
  "A UNSUBSCRIBE frame constructor."
  ([headers]
   (unsubscribe headers ""))
  ([headers body]
   (frame :unsubscribe headers body)))

(defn publish
  "A PUBLISH frame constructor."
  ([headers]
   (publish headers ""))
  ([headers body]
   (frame :publish headers body)))

(defn put
  "A PUT frame constructor."
  ([headers]
   (put headers ""))
  ([headers body]
   (frame :put headers body)))

(defn take
  "A TAKE frame constructor."
  ([headers]
   (take headers ""))
  ([headers body]
   (frame :take headers body)))

(defn consume
  "A TAKE frame constructor."
  ([headers]
   (consume headers ""))
  ([headers body]
   (frame :consume headers body)))

(defn frame?
  "Return true if a provided frame is a true
  instance of Frame type."
  [frame]
  (instance? Frame frame))

(ns postal.frames
  "A frame types definition."
  (:refer-clojure :exclude [take])

(defrecord Frame [command headers body])

(defn frame
  "A generic frame constructor."
  ([command headers]
   (frame command headers ""))
  ([command headers body]
   (Frame. command headers body)))

(defn query
  "A QUERY frame constructor."
  ([headers]
   (query headers ""))
  ([headers body]
   (frame :query headers body)))

(defn novelty
  "A NOVELTY frame constructor."
  ([headers]
   (novelty headers ""))
  ([headers body]
   (frame :novelty headers body)))

(defn subscribe
  "A SUBSCRIBE frame constructor."
  ([headers]
   (subscribe headers ""))
  ([headers body]
   (frame :subscribe headers body)))

(defn unsubscribe
  "A UNSUBSCRIBE frame constructor."
  ([headers]
   (unsubscribe headers ""))
  ([headers body]
   (frame :unsubscribe headers body)))

(defn publish
  "A PUBLISH frame constructor."
  ([headers]
   (publish headers ""))
  ([headers body]
   (frame :publish headers body)))

(defn put
  "A PUT frame constructor."
  ([headers]
   (put headers ""))
  ([headers body]
   (frame :put headers body)))

(defn take
  "A TAKE frame constructor."
  ([headers]
   (take headers ""))
  ([headers body]
   (frame :take headers body)))

(defn consume
  "A TAKE frame constructor."
  ([headers]
   (consume headers ""))
  ([headers body]
   (frame :consume headers body)))

(defn frame?
  "Return true if a provided frame is a true
  instance of Frame type."
  [frame]
  (instance? Frame frame))

Exclude take from cljs.core ns.

Exclude take from cljs.core ns.


(defproject replete "0.1.0"
  :dependencies [[andare "0.7.0"]                           ; Update in script/build also
                 [cljsjs/parinfer "1.8.1-0"]
                 [com.cognitect/transit-clj "0.8.300"]
                 [com.cognitect/transit-cljs "0.8.239"]
                 [fipp "0.6.8"]
                 [tailrecursion/cljson "1.0.7"]
                 [malabarba/lazy-map "1.1"]
                 [org.clojure/clojure "1.8.0"]
                 [org.clojure/clojurescript "1.9.946"]
                 [org.clojure/test.check "0.10.0-alpha2"]] ; Clone and build test.check master (ref'd in script/build)
  :clean-targets ["out" "target"]
  :plugins [[lein-cljsbuild "1.1.5"]]
  :cljsbuild {:builds {:test {:source-paths ["src" "test"]
                              :compiler {:output-to "test/resources/compiled.js"
                                         :optimizations :whitespace
                                         :pretty-print true}}}
              :test-commands {"test" ["phantomjs"
                                      "test/resources/test.js"
                                      "test/resources/test.html"]}})

(defproject replete "0.1.0"
  :dependencies [[andare "0.7.0"]                           ; Update in script/build also
                 [cljsjs/parinfer "1.8.1-0"]
                 [com.cognitect/transit-clj "0.8.300"]
                 [com.cognitect/transit-cljs "0.8.243"]
                 [fipp "0.6.8"]
                 [tailrecursion/cljson "1.0.7"]
                 [malabarba/lazy-map "1.1"]
                 [org.clojure/clojure "1.8.0"]
                 [org.clojure/clojurescript "1.9.946"]
                 [org.clojure/test.check "0.10.0-alpha2"]] ; Clone and build test.check master (ref'd in script/build)
  :clean-targets ["out" "target"]
  :plugins [[lein-cljsbuild "1.1.5"]]
  :cljsbuild {:builds {:test {:source-paths ["src" "test"]
                              :compiler {:output-to "test/resources/compiled.js"
                                         :optimizations :whitespace
                                         :pretty-print true}}}
              :test-commands {"test" ["phantomjs"
                                      "test/resources/test.js"
                                      "test/resources/test.html"]}})

Update to transit-cljs 0.8.243

Update to transit-cljs 0.8.243


(ns figwheel.main.watching
  (:require
   [clojure.java.io :as io]
   [clojure.string :as string]
   [hawk.core :as hawk]))

(def ^:dynamic *watcher* (atom {:watcher nil :watches {}}))

(defn alter-watches [{:keys [watcher watches]} f]
  (when watcher (hawk/stop! watcher))
  (let [watches (f watches)
        watcher (apply hawk/watch! (map vector (vals watches)))]
    {:watcher watcher :watches watches}))

(defn add-watch! [watch-key watch]
  (swap! *watcher* alter-watches #(assoc % watch-key watch)))

(defn remove-watch! [watch-key]
  (swap! *watcher* alter-watches #(dissoc % watch-key)))

(defn reset-watch! []
  (let [{:keys [watcher]} @*watcher*]
    (when watcher (hawk/stop! watcher))
    (reset! *watcher* {})))

(defn running? []
  (some-> *watcher* deref :watcher :thread .isAlive))

(defn join []
  (some-> *watcher* deref :watcher :thread .join))

(defn stop! []
  (some-> *watcher* deref :watcher hawk/stop!))

(defn throttle [millis f]
  (fn [{:keys [collector] :as ctx} e]
    (let [collector (or collector (atom {}))
          {:keys [collecting? events]} (deref collector)]
      (if collecting?
        (swap! collector update :events (fnil conj []) e)
        (do
          (swap! collector assoc :collecting? true)
          (future (Thread/sleep millis)
                  (let [events (volatile! nil)]
                    (swap! collector
                           #(-> %
                                (assoc :collecting? false)
                                (update :events (fn [evts] (vreset! events evts) nil))))
                    (f (cons e @events))))))
      (assoc ctx :collector collector))))

(defn file-suffix [file]
  (last (string/split (.getName (io/file file)) #"\.")))

(defn real-file? [file]
  (and file
       (.isFile file)
       (not (.isHidden file))
       (not (#{\. \#} (first (.getName file))))))

(defn suffix-filter [suffixes]
  (fn [_ {:keys [file]}]
    (and (real-file? file)
         (suffixes (file-suffix file)))))

(ns figwheel.main.watching
  (:require
   [clojure.java.io :as io]
   [clojure.string :as string]
   [hawk.core :as hawk]))

(def ^:dynamic *watcher* (atom {:watcher nil :watches {}}))

(defn alter-watches [{:keys [watcher watches]} f]
  (when watcher (hawk/stop! watcher))
  (let [watches (f watches)
        watcher (when (not-empty watches)
                  (apply hawk/watch! (map vector (vals watches))))]
    {:watcher watcher
     :watches watches}))

(defn add-watch! [watch-key watch]
  (swap! *watcher* alter-watches #(assoc % watch-key watch)))

(defn remove-watch! [watch-key]
  (swap! *watcher* alter-watches #(dissoc % watch-key)))

(defn reset-watch! []
  (let [{:keys [watcher]} @*watcher*]
    (when watcher (hawk/stop! watcher))
    (reset! *watcher* {})))

(defn running? []
  (some-> *watcher* deref :watcher :thread .isAlive))

(defn join []
  (some-> *watcher* deref :watcher :thread .join))

(defn stop! []
  (some-> *watcher* deref :watcher hawk/stop!))

(defn throttle [millis f]
  (fn [{:keys [collector] :as ctx} e]
    (let [collector (or collector (atom {}))
          {:keys [collecting? events]} (deref collector)]
      (if collecting?
        (swap! collector update :events (fnil conj []) e)
        (do
          (swap! collector assoc :collecting? true)
          (future (Thread/sleep millis)
                  (let [events (volatile! nil)]
                    (swap! collector
                           #(-> %
                                (assoc :collecting? false)
                                (update :events (fn [evts] (vreset! events evts) nil))))
                    (f (cons e @events))))))
      (assoc ctx :collector collector))))

(defn file-suffix [file]
  (last (string/split (.getName (io/file file)) #"\.")))

(defn real-file? [file]
  (and file
       (.isFile file)
       (not (.isHidden file))
       (not (#{\. \#} (first (.getName file))))))

(defn suffix-filter [suffixes]
  (fn [_ {:keys [file]}]
    (and (real-file? file)
         (suffixes (file-suffix file)))))

fix (reset) error

figwheel.main: fix (reset) error


(ns bake.test
  (:use clojure.test
        [cake :only [*config*]]
        [bake.core :only [verbose? log as-fn]]
        [bake.reload :only [last-reloaded last-modified reload]]
        [bake.notify :only [notify]])
  (:import [java.io StringWriter IOException]))

(do
  ;; these functions were written by Mark McGranaghan
  ;; https://github.com/mmcgrana/clj-stacktrace

  (defn re-gsub
    "Simple version of re-gsub that only supports string replacements."
    [^java.util.regex.Pattern regex replacement ^String string]
    (.. regex (matcher string) (replaceAll replacement)))

  (defn re-match?
    "Returns true iff the given string contains a match for the given pattern."
    [^java.util.regex.Pattern pattern string]
    (.find (.matcher pattern string)))

  (defn re-get
    "Returns the nth captured group resulting from matching the given pattern
  against the given string, or nil if no match is found."
    [re s n]
    (let [m (re-matcher re s)]
      (if (.find m)
        (.group m n))))

  (defn- clojure-code?
    "Returns true if the filename is non-null and indicates a clj source file."
    [class-name file]
    (or (re-match? #"^user" class-name)
        (and file (re-match? #"\.clj$" file))))

  (defn- clojure-ns
    "Returns the clojure namespace name implied by the bytecode class name."
    [class-name]
    (re-gsub #"_" "-" (re-get #"([^$]+)\$" class-name 1)))

  ; drop everything before and including the first $
  ; drop everything after and including and the second $
  ; drop any __xyz suffixes
  ; sub _PLACEHOLDER_ for the corresponding char
  (def clojure-fn-subs
    [[#"^[^$]*\$" ""]
     [#"\$.*"    ""]
     [#"__\d+.*"  ""]
     [#"_QMARK_"  "?"]
     [#"_BANG_"   "!"]
     [#"_PLUS_"   "+"]
     [#"_GT_"     ">"]
     [#"_LT_"     "<"]
     [#"_EQ_"     "="]
     [#"_STAR_"   "*"]
     [#"_SLASH_"  "/"]
     [#"_"        "-"]])

  (defn- clojure-fn
    "Returns the clojure function name implied by the bytecode class name."
    [class-name]
    (reduce
     (fn [base-name [pattern sub]] (re-gsub pattern sub base-name))
     class-name
     clojure-fn-subs))

  (defn- clojure-annon-fn?
    "Returns true if the bytecode class name implies an anonymous inner fn."
    [class-name]
    (re-match? #"\$.*\$" class-name))

  (defn parse-trace-elem
    "Returns a map of information about the java trace element.
  All returned maps have the keys:
  :file      String of source file name.
  :line      Number of source line number of the enclosing form.
  Additionally for elements from Java code:
  :java      true, to indicate a Java elem.
  :class     String of the name of the class to which the method belongs.
  Additionally for elements from Clojure code:
  :clojure   true, to inidcate a Clojure elem.
  :ns        String representing the namespace of the function.
  :fn        String representing the name of the enclosing var for the function.
  :annon-fn  true iff the function is an anonymous inner fn."
    [elem]
    (let [class-name (.getClassName elem)
          file       (.getFileName  elem)
          line       (let [l (.getLineNumber elem)] (if (> l 0) l))
          parsed     {:file file :line line}]
      (if (clojure-code? class-name file)
        (assoc parsed
          :clojure true
          :ns       (clojure-ns class-name)
          :fn       (clojure-fn class-name)
          :annon-fn (clojure-annon-fn? class-name))
        (assoc parsed
          :java true
          :class class-name
          :method (.getMethodName elem)))))

  (defn parse-trace-elems
    "Returns a seq of maps providing usefull information about the java stack
  trace elements. See parse-trace-elem."
    [elems]
    (map parse-trace-elem elems))

  (defn- trim-redundant
    "Returns the portion of the tail of causer-elems that is not duplicated in
  the tail of caused-elems. This corresponds to the \"...26 more\" that you
  see at the bottom of regular trace dumps."
    [causer-parsed-elems caused-parsed-elems]
    (loop [rcauser-parsed-elems (reverse causer-parsed-elems)
           rcaused-parsed-elems (reverse caused-parsed-elems)]
      (if-let [rcauser-bottom (first rcauser-parsed-elems)]
        (if (= rcauser-bottom (first rcaused-parsed-elems))
          (recur (next rcauser-parsed-elems) (next rcaused-parsed-elems))
          (reverse rcauser-parsed-elems)))))

  (defn- parse-cause-exception
    "Like parse-exception, but for causing exceptions. The returned map has all
  of the same keys as the map returned by parse-exception, and one added one:
  :trimmed-elems  A subset of :trace-elems representing the portion of the
                  top of the stacktrace not shared with that of the caused
                  exception."
    [causer-e caused-parsed-elems]
    (let [parsed-elems (parse-trace-elems (.getStackTrace causer-e))
          base {:class         (class causer-e)
                :message       (.getMessage causer-e)
                :trace-elems   parsed-elems
                :trimmed-elems (trim-redundant parsed-elems caused-parsed-elems)}]
      (if-let [cause (.getCause causer-e)]
        (assoc base :cause (parse-cause-exception cause parsed-elems))
        base)))

  (defn parse-exception
    "Returns a Clojure map providing usefull informaiton about the exception.
  The map has keys
  :class        Class of the exception.
  :message      Regular exception message string.
  :trace-elems  Parsed stack trace elems, see parse-trace-elem.
  :cause        See parse-cause-exception."
    [e]
    (let [parsed-elems (parse-trace-elems (.getStackTrace e))
          base {:class       (class e)
                :message     (.getMessage e)
                :trace-elems parsed-elems}]
      (if-let [cause (.getCause e)]
        (assoc base :cause (parse-cause-exception cause parsed-elems))
        base))))

(defn get-test-vars [namespaces opts]
  (let [[tags functions ns-opts] (map opts [:tags :functions :namespaces])
        ns-opts (as-fn ns-opts)
        run? (fn [ns]
               (if (ns-opts ns)
                 (if (ns-resolve ns 'test-ns-hook)
                   (comp #{'test-ns-hook} first)
                   (comp :test meta second))
                 (fn [[fn-name f]]
                   (or (some tags (:tags (meta f)))
                       (functions (apply symbol (map name [ns fn-name])))))))
        get-tests-for-ns (fn [ns]
                           (require ns)
                           (for [f (filter (run? ns) (ns-publics ns))]
                             (key f)))]
    (reduce (fn [acc ns]
              (if-let [test-fns (seq (get-tests-for-ns ns))]
                (assoc acc ns (doall test-fns))
                acc))
            {}
            namespaces)))

(declare *ns-results* *current-test*)

(defn update-results [m]
  (swap! *ns-results* update-in [:tests *current-test* :assertions] (fnil conj []) m))

(defmulti my-report :type)

(defmethod my-report :pass [m]
  (update-results (dissoc m :actual)))

(defmethod my-report :fail [m]
  (update-results m))

(defmethod my-report :error [m]
  (update-results (update-in m [:actual] parse-exception)))

;; the methods below are never called because i'm calling test-var directly

(defmethod my-report :default [m]
  (prn :here))

(defmethod my-report :summary [m]
  (prn :here))

(defmethod my-report :begin-test-ns [m]
  (prn :here))

(defmethod my-report :end-test-ns [m]
  (prn :here))

(defmethod my-report :begin-test-var [m]
  (set! *current-test* (:name (meta (:var m))))
  (set! *out* (StringWriter.))
  (set! *err* *out*))

(defmethod my-report :end-test-var [m]
  (swap! *ns-results* assoc-in [:tests *current-test* :out] (not-empty (.toString *out*)))
  (set! *current-test* nil))

(defn run-ns-tests [ns tests]
  (let [ns-meta (meta (find-ns ns))
        each-fixtures (join-fixtures (:clojure.test/each-fixtures ns-meta))
        once-fixtures (join-fixtures (:clojure.test/once-fixtures ns-meta))]
    (require ns)
    (binding [report my-report
              *test-out* (StringWriter.)
              *out* *out* ;; this is so it gets restored
              *err* *err*
              *report-counters* (ref *initial-report-counters*)
              *ns-results* (atom {:tests {}})
              *current-test* nil]
      (if (= '(test-ns-hook) tests)
        ((var-get (ns-resolve ns 'test-ns-hook)))
        (once-fixtures
         (fn []
           (doseq [test tests]
             (each-fixtures
              (fn []
                (test-var (ns-resolve ns test))))))))
      @*ns-results*)))

(ns bake.test
  (:use clojure.test
        [cake :only [*config*]]
        [bake.core :only [verbose? log as-fn]]
        [bake.reload :only [last-reloaded last-modified reload]]
        [bake.notify :only [notify]])
  (:import [java.io StringWriter IOException]))

(do
  ;; these functions were written by Mark McGranaghan
  ;; https://github.com/mmcgrana/clj-stacktrace

  (defn re-gsub
    "Simple version of re-gsub that only supports string replacements."
    [^java.util.regex.Pattern regex replacement ^String string]
    (.. regex (matcher string) (replaceAll replacement)))

  (defn re-match?
    "Returns true iff the given string contains a match for the given pattern."
    [^java.util.regex.Pattern pattern string]
    (.find (.matcher pattern string)))

  (defn re-get
    "Returns the nth captured group resulting from matching the given pattern
  against the given string, or nil if no match is found."
    [re s n]
    (let [m (re-matcher re s)]
      (if (.find m)
        (.group m n))))

  (defn- clojure-code?
    "Returns true if the filename is non-null and indicates a clj source file."
    [class-name file]
    (or (re-match? #"^user" class-name)
        (and file (re-match? #"\.clj$" file))))

  (defn- clojure-ns
    "Returns the clojure namespace name implied by the bytecode class name."
    [class-name]
    (re-gsub #"_" "-" (re-get #"([^$]+(?=\$)|.+(?=\.))" class-name 1)))

  ; drop everything before and including the first $
  ; drop everything after and including and the second $
  ; drop any __xyz suffixes
  ; sub _PLACEHOLDER_ for the corresponding char
  (def clojure-fn-subs
    [[#"^[^$]*\$" ""]
     [#"\$.*"    ""]
     [#"__\d+.*"  ""]
     [#"_QMARK_"  "?"]
     [#"_BANG_"   "!"]
     [#"_PLUS_"   "+"]
     [#"_GT_"     ">"]
     [#"_LT_"     "<"]
     [#"_EQ_"     "="]
     [#"_STAR_"   "*"]
     [#"_SLASH_"  "/"]
     [#"_"        "-"]])

  (defn- clojure-fn
    "Returns the clojure function name implied by the bytecode class name."
    [class-name]
    (reduce
     (fn [base-name [pattern sub]] (re-gsub pattern sub base-name))
     class-name
     clojure-fn-subs))

  (defn- clojure-annon-fn?
    "Returns true if the bytecode class name implies an anonymous inner fn."
    [class-name]
    (re-match? #"\$.*\$" class-name))

  (defn parse-trace-elem
    "Returns a map of information about the java trace element.
  All returned maps have the keys:
  :file      String of source file name.
  :line      Number of source line number of the enclosing form.
  Additionally for elements from Java code:
  :java      true, to indicate a Java elem.
  :class     String of the name of the class to which the method belongs.
  Additionally for elements from Clojure code:
  :clojure   true, to inidcate a Clojure elem.
  :ns        String representing the namespace of the function.
  :fn        String representing the name of the enclosing var for the function.
  :annon-fn  true iff the function is an anonymous inner fn."
    [elem]
    (let [class-name (.getClassName elem)
          file       (.getFileName  elem)
          line       (let [l (.getLineNumber elem)] (if (> l 0) l))
          parsed     {:file file :line line}]
      (if (clojure-code? class-name file)
        (assoc parsed
          :clojure true
          :ns       (clojure-ns class-name)
          :fn       (clojure-fn class-name)
          :annon-fn (clojure-annon-fn? class-name))
        (assoc parsed
          :java true
          :class class-name
          :method (.getMethodName elem)))))

  (defn parse-trace-elems
    "Returns a seq of maps providing usefull information about the java stack
  trace elements. See parse-trace-elem."
    [elems]
    (map parse-trace-elem elems))

  (defn- trim-redundant
    "Returns the portion of the tail of causer-elems that is not duplicated in
  the tail of caused-elems. This corresponds to the \"...26 more\" that you
  see at the bottom of regular trace dumps."
    [causer-parsed-elems caused-parsed-elems]
    (loop [rcauser-parsed-elems (reverse causer-parsed-elems)
           rcaused-parsed-elems (reverse caused-parsed-elems)]
      (if-let [rcauser-bottom (first rcauser-parsed-elems)]
        (if (= rcauser-bottom (first rcaused-parsed-elems))
          (recur (next rcauser-parsed-elems) (next rcaused-parsed-elems))
          (reverse rcauser-parsed-elems)))))

  (defn- parse-cause-exception
    "Like parse-exception, but for causing exceptions. The returned map has all
  of the same keys as the map returned by parse-exception, and one added one:
  :trimmed-elems  A subset of :trace-elems representing the portion of the
                  top of the stacktrace not shared with that of the caused
                  exception."
    [causer-e caused-parsed-elems]
    (let [parsed-elems (parse-trace-elems (.getStackTrace causer-e))
          base {:class         (class causer-e)
                :message       (.getMessage causer-e)
                :trace-elems   parsed-elems
                :trimmed-elems (trim-redundant parsed-elems caused-parsed-elems)}]
      (if-let [cause (.getCause causer-e)]
        (assoc base :cause (parse-cause-exception cause parsed-elems))
        base)))

  (defn parse-exception
    "Returns a Clojure map providing usefull informaiton about the exception.
  The map has keys
  :class        Class of the exception.
  :message      Regular exception message string.
  :trace-elems  Parsed stack trace elems, see parse-trace-elem.
  :cause        See parse-cause-exception."
    [e]
    (let [parsed-elems (parse-trace-elems (.getStackTrace e))
          base {:class       (class e)
                :message     (.getMessage e)
                :trace-elems parsed-elems}]
      (if-let [cause (.getCause e)]
        (assoc base :cause (parse-cause-exception cause parsed-elems))
        base))))

(defn get-test-vars [namespaces opts]
  (let [[tags functions ns-opts] (map opts [:tags :functions :namespaces])
        ns-opts (as-fn ns-opts)
        run? (fn [ns]
               (if (ns-opts ns)
                 (if (ns-resolve ns 'test-ns-hook)
                   (comp #{'test-ns-hook} first)
                   (comp :test meta second))
                 (fn [[fn-name f]]
                   (or (some tags (:tags (meta f)))
                       (functions (apply symbol (map name [ns fn-name])))))))
        get-tests-for-ns (fn [ns]
                           (require ns)
                           (for [f (filter (run? ns) (ns-publics ns))]
                             (key f)))]
    (reduce (fn [acc ns]
              (if-let [test-fns (seq (get-tests-for-ns ns))]
                (assoc acc ns (doall test-fns))
                acc))
            {}
            namespaces)))

(declare *ns-results* *current-test*)

(defn update-results [m]
  (swap! *ns-results* update-in [:tests *current-test* :assertions] (fnil conj []) m))

(defmulti my-report :type)

(defmethod my-report :pass [m]
  (update-results (dissoc m :actual)))

(defmethod my-report :fail [m]
  (update-results m))

(defmethod my-report :error [m]
  (update-results (update-in m [:actual] parse-exception)))

;; the methods below are never called because i'm calling test-var directly

(defmethod my-report :default [m]
  (prn :here))

(defmethod my-report :summary [m]
  (prn :here))

(defmethod my-report :begin-test-ns [m]
  (prn :here))

(defmethod my-report :end-test-ns [m]
  (prn :here))

(defmethod my-report :begin-test-var [m]
  (set! *current-test* (:name (meta (:var m))))
  (set! *out* (StringWriter.))
  (set! *err* *out*))

(defmethod my-report :end-test-var [m]
  (swap! *ns-results* assoc-in [:tests *current-test* :out] (not-empty (.toString *out*)))
  (set! *current-test* nil))

(defn run-ns-tests [ns tests]
  (let [ns-meta (meta (find-ns ns))
        each-fixtures (join-fixtures (:clojure.test/each-fixtures ns-meta))
        once-fixtures (join-fixtures (:clojure.test/once-fixtures ns-meta))]
    (require ns)
    (binding [report my-report
              *test-out* (StringWriter.)
              *out* *out* ;; this is so it gets restored
              *err* *err*
              *report-counters* (ref *initial-report-counters*)
              *ns-results* (atom {:tests {}})
              *current-test* nil]
      (if (= '(test-ns-hook) tests)
        ((var-get (ns-resolve ns 'test-ns-hook)))
        (once-fixtures
         (fn []
           (doseq [test tests]
             (each-fixtures
              (fn []
                (test-var (ns-resolve ns test))))))))
      @*ns-results*)))

Change regex for stacktrace stuff.

Change regex for stacktrace stuff.

It didn't work for defrecord/deftype functions; now it's
at least kinda working.


(ns re-frame.core
  (:require
    [re-frame.events     :as events]
    [re-frame.subs       :as subs]
    [re-frame.fx         :as fx]
    [re-frame.router     :as router]
    [re-frame.loggers    :as loggers]
    [re-frame.middleware :as middleware]))

;; --  dispatch
(def dispatch         router/dispatch)
(def dispatch-sync    router/dispatch-sync)

;; --  subscribe
(def reg-sub-raw         subs/register)
(def reg-sub             subs/register-pure)
(def clear-all-subs!     subs/clear-all-handlers!)
(def subscribe           subs/subscribe)

;; --  effects
(def reg-fx         fx/register)
(def clear-fx!      fx/clear-handler!)
(def clear-all-fx!  fx/clear-all-handlers!)

;; --  middleware
(def pure        middleware/pure)
(def fx          fx/fx)
(def debug       middleware/debug)
(def path        middleware/path)
(def enrich      middleware/enrich)
(def trim-v      middleware/trim-v)
(def after       middleware/after)
(def on-changes  middleware/on-changes)

;; --  Events
(def clear-all-events!   events/clear-all-handlers!)
(def clear-event!        events/clear-handler!)

;; Registers a pure event handler. Places pure middleware in the correct, LHS position.

(defn reg-event
  ([id handler]
    (events/register-base id pure handler))
  ([id middleware handler]
    (events/register-base id [pure middleware] handler)))

;; Registers an effectful event handler. Places fx middleware in the correct, LHS position.
(defn reg-event-fx
  ([id handler]
   (events/register-base id fx handler))
  ([id middleware handler]
   (events/register-base id [fx middleware] handler)))

;; --  Logging -----
;; Internally, re-frame uses the logging functions: warn, log, error, group and groupEnd
;; By default, these functions map directly to the js/console implementations,
;; but you can override with your own fns (set or subset).
;; Example Usage:
;;   (defn my-fn [& args]  (post-it-somewhere (apply str args)))
;;   (re-frame.core/set-loggers!  {:warn my-fn :log my-fn})    ;; I should override the rest of them too.
(def set-loggers! loggers/set-loggers!)

;; If you are writing an extension to re-frame, like perhaps
;; an effeects handler, you may want to use re-frame logging.
;;
;; usage:  (console :error "this is bad: " a-variable " and " anotherv)
;;         (console :warn "possible breach of containment wall at: " dt)
(def console loggers/console)

;; -- Event Procssing Callbacks

(defn add-post-event-callback
  "Registers a callback function 'f'.
  f will be called after each dispatched event is procecessed
  f will be called with two arguments:
    - the event's vector. That which was dispatched orignally.
    - the further event queue - what is still to be processed. A PersistentQueue.

  This is useful in advanced cases like:
    - you are implementing a complex bootstrap pipeline
    - you want to create your own handling infrastructure, with perhaps multiple
      handlers for the one event, etc.  Hook in here.
    - libraries providing 'isomorphic javascript' rendering on  Nodejs or Nashorn.
  "
  [f]
  (router/add-post-event-callback re-frame.router/event-queue f))

(defn remove-post-event-callback
  [f]
  (router/remove-post-event-callback re-frame.router/event-queue f))

;; --  Helpful Message
;; Assisting the v0.0.7 ->  v0.0.8 tranistion.  Remove in v0.0.9
(defn register-handler
  [& args]
  (console :error  "re-frame:  \"register-handler\" has been renamed \"reg-event\""))

(defn register-sub
  [& args]
  (console :error  "re-frame:  \"register-sub\" has been renamed \"reg-sub-raw\"."))

;; v0.0.8 alpha2 -> alpha3
(defn def-fx    [& args]  (console :error  "re-frame:  in v0.0.8-alpha3 \"def-fx\" was renamed \"reg-fx\"."))
(defn def-event [& args]  (console :error  "re-frame:  in v0.0.8-alpha3 \"def-event\" was renamed \"reg-event\"."))
(defn def-sub   [& args]  (console :error  "re-frame:  in v0.0.8-alpha3 \"def-sub\" was renamed \"reg-sub\"."))

add helpful error messages which explain recent renaming


(ns re-frame.subs
 (:require
   [re-frame.db        :refer [app-db]]
   [re-frame.interop   :refer [add-on-dispose! debug-enabled? make-reaction ratom? deref? dispose! reagent-id]]
   [re-frame.loggers   :refer [console]]
   [re-frame.utils     :refer [first-in-vector]]
   [re-frame.registrar :refer [get-handler clear-handlers register-handler]]
   [re-frame.trace     :as trace :include-macros true]))

(def kind :sub)
(assert (re-frame.registrar/kinds kind))

;; -- cache -------------------------------------------------------------------
;;
;; De-duplicate subscriptions. If two or more equal subscriptions
;; are concurrently active, we want only one handler running.
;; Two subscriptions are "equal" if their query vectors test "=".
(def query->reaction (atom {}))

(defn clear-subscription-cache!
  "Causes all subscriptions to be removed from the cache.
  Does this by:
     1. running on-dispose on all cached subscriptions
     2. These on-dispose will then do the removal of themselves.

  This is a development time tool. Useful when reloading Figwheel code
  after a React exception, because React components won't have been
  cleaned up properly. And this, in turn, means the subscriptions within those
  components won't have been cleaned up correctly. So this forces the issue."
  []
  (doseq [[k rxn] @query->reaction]
    (dispose! rxn))
  (if (not-empty @query->reaction)
    (console :warn "Subscription cache should be empty after clearing it.")))

(defn clear-all-handlers!
  "Unregisters all existing subscription handlers"
  []
  (clear-handlers kind)
  (clear-subscription-cache!))

(defn cache-and-return
  "cache the reaction r"
  [query-v dynv r]
  (let [cache-key [query-v dynv]]
    ;; when this reaction is no longer being used, remove it from the cache
    (add-on-dispose! r #(trace/with-trace {:operation (first-in-vector query-v)
                                           :op-type   :sub/dispose
                                           :tags      {:query-v  query-v
                                                       :reaction (reagent-id r)}}
                                          (swap! query->reaction
                                                 (fn [query-cache]
                                                   (if (and (contains? query-cache cache-key) (identical? r (get query-cache cache-key)))
                                                     (dissoc query-cache cache-key)
                                                     query-cache)))))
    ;; cache this reaction, so it can be used to deduplicate other, later "=" subscriptions
    (swap! query->reaction (fn [query-cache]
                             (when debug-enabled?
                               (when (contains? query-cache cache-key)
                                 (console :warn "re-frame: Adding a new subscription to the cache while there is an existing subscription in the cache" cache-key)))
                             (assoc query-cache cache-key r)))
    (trace/merge-trace! {:tags {:reaction (reagent-id r)}})
    r)) ;; return the actual reaction

(defn cache-lookup
  ([query-v]
   (cache-lookup query-v []))
  ([query-v dyn-v]
   (get @query->reaction [query-v dyn-v])))

;; -- subscribe ---------------------------------------------------------------

(defn subscribe
  "Given a `query`, returns a Reagent `reaction` which, over
  time, reactively delivers a stream of values. So in FRP-ish terms,
  it returns a Signal.

  To obtain the returned Signal/Stream's current value, it must be `deref`ed.

  `query` is a vector of at least one element. The first element is the
  `query-id`, typically a namespaced keyword. The rest of the vector's
  elements are optional, additional values which parameterise the query
  performed.

  `dynv` is an optional 3rd argument, `which is a vector of further input
  signals (atoms, reactions, etc), NOT values. This argument exists for
  historical reasons and is borderline deprecated these days.

  Example Usage:
  --------------

    (subscribe [:items])
    (subscribe [:items \"blue\" :small])
    (subscribe [:items {:colour \"blue\"  :size :small}])

  Note: for any given call to `subscribe` there must have been a previous call
  to `reg-sub`, registering the query handler (function) for the `query-id` given.

  Hint
  ----

  When used in a view function BE SURE to `deref` the returned value.
  In fact, to avoid any mistakes, some prefer to define:

     (def <sub  (comp deref re-frame.core/subscribe))

  And then, within their views, they call  `(<sub [:items :small])` rather
  than using `subscribe` directly.

  De-duplication
  --------------

  XXX
  "

  ([query]
   (trace/with-trace {:operation (first-in-vector query)
                      :op-type   :sub/create
                      :tags      {:query-v query}}
     (if-let [cached (cache-lookup query)]
       (do
         (trace/merge-trace! {:tags {:cached?  true
                                     :reaction (reagent-id cached)}})
         cached)

       (let [query-id   (first-in-vector query)
             handler-fn (get-handler kind query-id)]
         (trace/merge-trace! {:tags {:cached? false}})
         (if (nil? handler-fn)
           (do (trace/merge-trace! {:error true})
               (console :error (str "re-frame: no subscription handler registered for: " query-id ". Returning a nil subscription.")))
           (cache-and-return query [] (handler-fn app-db query)))))))

  ([query dynv]
   (trace/with-trace {:operation (first-in-vector query)
                      :op-type   :sub/create
                      :tags      {:query-v query
                                  :dyn-v   dynv}}
     (if-let [cached (cache-lookup query dynv)]
       (do
         (trace/merge-trace! {:tags {:cached?  true
                                     :reaction (reagent-id cached)}})
         cached)
       (let [query-id   (first-in-vector query)
             handler-fn (get-handler kind query-id)]
         (trace/merge-trace! {:tags {:cached? false}})
         (when debug-enabled?
           (when-let [not-reactive (not-empty (remove ratom? dynv))]
             (console :warn "re-frame: your subscription's dynamic parameters that don't implement IReactiveAtom:" not-reactive)))
         (if (nil? handler-fn)
           (do (trace/merge-trace! {:error true})
               (console :error (str "re-frame: no subscription handler registered for: " query-id ". Returning a nil subscription.")))
           (let [dyn-vals (make-reaction (fn [] (mapv deref dynv)))
                 sub      (make-reaction (fn [] (handler-fn app-db query @dyn-vals)))]
             ;; handler-fn returns a reaction which is then wrapped in the sub reaction
             ;; need to double deref it to get to the actual value.
             ;(console :log "Subscription created: " v dynv)
             (cache-and-return query dynv (make-reaction (fn [] @@sub))))))))))

;; -- reg-sub -----------------------------------------------------------------

(defn- map-vals
  "Returns a new version of 'm' in which 'f' has been applied to each value.
  (map-vals inc {:a 4, :b 2}) => {:a 5, :b 3}"
  [f m]
  (into (empty m)
        (map (fn [[k v]] [k (f v)]))
        m))

(defn map-signals
  "Runs f over signals. Signals may take several
  forms, this function handles all of them."
  [f signals]
  (cond
    (sequential? signals) (map f signals)
    (map? signals) (map-vals f signals)
    (deref? signals) (f signals)
    :else '()))

(defn to-seq
  "Coerces x to a seq if it isn't one already"
  [x]
  (if (sequential? x)
    x
    (list x)))

(defn- deref-input-signals
  [signals query-id]
  (let [dereffed-signals (map-signals deref signals)]
    (cond
      (sequential? signals) (map deref signals)
      (map? signals) (map-vals deref signals)
      (deref? signals) (deref signals)
      :else (console :error "re-frame: in the reg-sub for" query-id ", the input-signals function returns:" signals))
    (trace/merge-trace! {:tags {:input-signals (doall (to-seq (map-signals reagent-id signals)))}})
    dereffed-signals))

(defn reg-sub
  "For a given `query-id`, register a `computation` function and input `signals`.

  At an abstract level, a call to this function allows you to register 'the mechanism'
  to later fulfil a call to `(subscribe [query-id ...])`.

  To say that another way, reg-sub allows you to create a template for a node
  in the signal graph. But note: reg-sub does not cause a node to be created.
  It simply allows you to register the template from which such a
  node could be created, if it were needed, sometime later, when the call
  to `subscribe` is made.

  reg-sub needs three things:
    - a `query-id`
    - the required inputs for this node
    - a computation function for this node

  The `query-id` is always the 1st argument to reg-sub and it is typically
  a namespaced keyword.

  A computation function is always the last argument and it has this general form:
    `(input-signals, query-vector) -> a-value`.  The `query-vector` is the
    `query` passed to `(subscribe query)` (see there for details), which may contain
    additional arguments to further parametrise the query.

  What goes in between the 1st and last args can vary, but whatever is there will
  define the input signals part of the template, and, as a result, it will control
  what values the computation functions gets as a first argument.

  There's 3 ways this function can be called - 3 ways to supply input signals:

  1. No input signals given:

     (reg-sub
       :query-id
       a-computation-fn)   ;; (fn [db v]  ... a-value)

     The node's input signal defaults to `app-db`, and the value within `app-db` is
     is given as the 1st argument to the computation function.

  2. A signal function is supplied:

     (reg-sub
       :query-id
       signal-fn     ;; <-- here
       computation-fn)

     When a node is created from the template, the `signal-fn` will be called and it
     is expected to return the input signal(s) as either a singleton, if there is only
     one, or a sequence if there are many, or a map with the signals as the values.

     The values from the nominated signals will be supplied as the 1st argument to the
     computation function - either a singleton, sequence or map of them, paralleling
     the structure returned by the signal function.

     Here, is an example signal-fn, which returns a vector of input signals.

       (fn [query-vec dynamic-vec]
         [(subscribe [:a-sub])
          (subscribe [:b-sub])])

     For that signal function, the computation function must be written
     to expect a vector of values for its first argument.
       (fn [[a b] _] ....)

     If the signal function was simpler and returned a singleton, like this:
        (fn [query-vec dynamic-vec]
          (subscribe [:a-sub]))

     then the computation function must be written to expect a single value
     as the 1st argument:

        (fn [a _] ...)

  3. Syntax Sugar

     ```clj
     (reg-sub
       :a-b-sub
       :<- [:a-sub]
       :<- [:b-sub]
       (fn [[a b] [_]] {:a a :b b}))
     ```

     This 3rd variation is syntactic sugar for the 2nd.  Instead of providing an
     `input signals` function, other subscriptions are used as automatic `input
     signals`: Each pair of `:<-` and a subscription vector is equivalent to a call to
     `(subscribe [:a-sub])`.

     Beware that in this syntax a single `:<-` pair is *not* wrapped in a vector, hence
     the same rule as for the 2nd variation applies: If you only provide one `input
     signal`, the computation function must expect a single value as the 1st argument:

     ```clj
     (reg-sub
       :a-sub
       :<- [:a-sub]
       (fn [a _] ...))
     ```

  For further understanding, read `/docs`, and look at the detailed comments in
  /examples/todomvc/src/subs.cljs
  "
  [query-id & args]
  (let [computation-fn (last args)
        input-args     (butlast args) ;; may be empty, or one signal fn, or pairs of  :<- / vector
        err-header     (str "re-frame: reg-sub for " query-id ", ")
        inputs-fn      (case (count input-args)
                         ;; no `inputs` function provided - give the default
                         0 (fn
                             ([_] app-db)
                             ([_ _] app-db))

                         ;; a single `inputs` fn
                         1 (let [f (first input-args)]
                             (when-not (fn? f)
                               (console :error err-header "2nd argument expected to be an inputs function, got:" f))
                             f)

                         ;; one sugar pair
                         2 (let [[marker vec] input-args]
                             (when-not (= :<- marker)
                               (console :error err-header "expected :<-, got:" marker))
                             (fn inp-fn
                               ([_] (subscribe vec))
                               ([_ _] (subscribe vec))))

                         ;; multiple sugar pairs
                         (let [pairs   (partition 2 input-args)
                               markers (map first pairs)
                               vecs    (map last pairs)]
                           (when-not (and (every? #{:<-} markers) (every? vector? vecs))
                             (console :error err-header "expected pairs of :<- and vectors, got:" pairs))
                           (fn inp-fn
                             ([_] (map subscribe vecs))
                             ([_ _] (map subscribe vecs)))))]
    (register-handler
      kind
      query-id
      (fn subs-handler-fn
        ([db query-vec]
         (let [subscriptions (inputs-fn query-vec)
               reaction-id   (atom nil)
               reaction      (make-reaction
                               (fn []
                                 (trace/with-trace {:operation (first-in-vector query-vec)
                                                    :op-type   :sub/run
                                                    :tags      {:query-v    query-vec
                                                                :reaction   @reaction-id}}
                                                   (let [subscription (computation-fn (deref-input-signals subscriptions query-id) query-vec)]
                                                     (trace/merge-trace! {:tags {:value subscription}})
                                                     subscription))))]

           (reset! reaction-id (reagent-id reaction))
           reaction))
        ([db query-vec dyn-vec]
         (let [subscriptions (inputs-fn query-vec dyn-vec)
               reaction-id   (atom nil)
               reaction      (make-reaction
                               (fn []
                                 (trace/with-trace {:operation (first-in-vector query-vec)
                                                    :op-type   :sub/run
                                                    :tags      {:query-v   query-vec
                                                                :dyn-v     dyn-vec
                                                                :reaction  @reaction-id}}
                                                   (let [subscription (computation-fn (deref-input-signals subscriptions query-id) query-vec dyn-vec)]
                                                     (trace/merge-trace! {:tags {:value subscription}})
                                                     subscription))))]

           (reset! reaction-id (reagent-id reaction))
           reaction))))))

(ns re-frame.subs
 (:require
   [re-frame.db        :refer [app-db]]
   [re-frame.interop   :refer [add-on-dispose! debug-enabled? make-reaction ratom? deref? dispose! reagent-id]]
   [re-frame.loggers   :refer [console]]
   [re-frame.utils     :refer [first-in-vector]]
   [re-frame.registrar :refer [get-handler clear-handlers register-handler]]
   [re-frame.trace     :as trace :include-macros true]))

(def kind :sub)
(assert (re-frame.registrar/kinds kind))

;; -- cache -------------------------------------------------------------------
;;
;; De-duplicate subscriptions. If two or more equal subscriptions
;; are concurrently active, we want only one handler running.
;; Two subscriptions are "equal" if their query vectors test "=".
(def query->reaction (atom {}))

(defn clear-subscription-cache!
  "Causes all subscriptions to be removed from the cache.
  Does this by:
     1. running `on-dispose` on all cached subscriptions
     2. Each `on-dispose` will perform the removal of themselves.

  This is for development time use. Useful when reloading Figwheel code
  after a React exception, because React components won't have been
  cleaned up properly. And this, in turn, means the subscriptions within those
  components won't have been cleaned up correctly. So this forces the issue."
  []
  (doseq [[k rxn] @query->reaction]
    (dispose! rxn))
  (if (not-empty @query->reaction)
    (console :warn "Subscription cache should be empty after clearing it.")))

(defn clear-all-handlers!
  "Unregisters all existing subscription handlers"
  []
  (clear-handlers kind)
  (clear-subscription-cache!))

(defn cache-and-return
  "cache the reaction r"
  [query-v dynv r]
  (let [cache-key [query-v dynv]]
    ;; when this reaction is no longer being used, remove it from the cache
    (add-on-dispose! r #(trace/with-trace {:operation (first-in-vector query-v)
                                           :op-type   :sub/dispose
                                           :tags      {:query-v  query-v
                                                       :reaction (reagent-id r)}}
                                          (swap! query->reaction
                                                 (fn [query-cache]
                                                   (if (and (contains? query-cache cache-key) (identical? r (get query-cache cache-key)))
                                                     (dissoc query-cache cache-key)
                                                     query-cache)))))
    ;; cache this reaction, so it can be used to deduplicate other, later "=" subscriptions
    (swap! query->reaction (fn [query-cache]
                             (when debug-enabled?
                               (when (contains? query-cache cache-key)
                                 (console :warn "re-frame: Adding a new subscription to the cache while there is an existing subscription in the cache" cache-key)))
                             (assoc query-cache cache-key r)))
    (trace/merge-trace! {:tags {:reaction (reagent-id r)}})
    r)) ;; return the actual reaction

(defn cache-lookup
  ([query-v]
   (cache-lookup query-v []))
  ([query-v dyn-v]
   (get @query->reaction [query-v dyn-v])))

;; -- subscribe ---------------------------------------------------------------

(defn subscribe
  "Given a `query`, returns a Reagent `reaction` which, over
  time, reactively delivers a stream of values. So in FRP-ish terms,
  it returns a `Signal`.

  To obtain the returned Signal/Stream's current value, it must be `deref`ed.

  `query` is a vector of at least one element. The first element is the
  `query-id`, typically a namespaced keyword. The rest of the vector's
  elements are optional, additional values which parameterise the query
  performed.

  `dynv` is an optional 3rd argument, which is a vector of further input
  signals (atoms, reactions, etc), NOT values. This argument exists for
  historical reasons and is borderline deprecated these days.

  Example Usage:
  --------------

    (subscribe [:items])
    (subscribe [:items \"blue\" :small])
    (subscribe [:items {:colour \"blue\"  :size :small}])

  Note: for any given call to `subscribe` there must have been a previous call
  to `reg-sub`, registering the query handler (function) for the `query-id` given.

  Hint
  ----

  When used in a view function BE SURE to `deref` the returned value.
  In fact, to avoid any mistakes, some prefer to define:

     (def <sub  (comp deref re-frame.core/subscribe))

  And then, within their views, they call  `(<sub [:items :small])` rather
  than using `subscribe` directly.

  De-duplication
  --------------

  XXX
  "

  ([query]
   (trace/with-trace {:operation (first-in-vector query)
                      :op-type   :sub/create
                      :tags      {:query-v query}}
     (if-let [cached (cache-lookup query)]
       (do
         (trace/merge-trace! {:tags {:cached?  true
                                     :reaction (reagent-id cached)}})
         cached)

       (let [query-id   (first-in-vector query)
             handler-fn (get-handler kind query-id)]
         (trace/merge-trace! {:tags {:cached? false}})
         (if (nil? handler-fn)
           (do (trace/merge-trace! {:error true})
               (console :error (str "re-frame: no subscription handler registered for: " query-id ". Returning a nil subscription.")))
           (cache-and-return query [] (handler-fn app-db query)))))))

  ([query dynv]
   (trace/with-trace {:operation (first-in-vector query)
                      :op-type   :sub/create
                      :tags      {:query-v query
                                  :dyn-v   dynv}}
     (if-let [cached (cache-lookup query dynv)]
       (do
         (trace/merge-trace! {:tags {:cached?  true
                                     :reaction (reagent-id cached)}})
         cached)
       (let [query-id   (first-in-vector query)
             handler-fn (get-handler kind query-id)]
         (trace/merge-trace! {:tags {:cached? false}})
         (when debug-enabled?
           (when-let [not-reactive (not-empty (remove ratom? dynv))]
             (console :warn "re-frame: your subscription's dynamic parameters that don't implement IReactiveAtom:" not-reactive)))
         (if (nil? handler-fn)
           (do (trace/merge-trace! {:error true})
               (console :error (str "re-frame: no subscription handler registered for: " query-id ". Returning a nil subscription.")))
           (let [dyn-vals (make-reaction (fn [] (mapv deref dynv)))
                 sub      (make-reaction (fn [] (handler-fn app-db query @dyn-vals)))]
             ;; handler-fn returns a reaction which is then wrapped in the sub reaction
             ;; need to double deref it to get to the actual value.
             ;(console :log "Subscription created: " v dynv)
             (cache-and-return query dynv (make-reaction (fn [] @@sub))))))))))

;; -- reg-sub -----------------------------------------------------------------

(defn- map-vals
  "Returns a new version of 'm' in which 'f' has been applied to each value.
  (map-vals inc {:a 4, :b 2}) => {:a 5, :b 3}"
  [f m]
  (into (empty m)
        (map (fn [[k v]] [k (f v)]))
        m))

(defn map-signals
  "Runs f over signals. Signals may take several
  forms, this function handles all of them."
  [f signals]
  (cond
    (sequential? signals) (map f signals)
    (map? signals) (map-vals f signals)
    (deref? signals) (f signals)
    :else '()))

(defn to-seq
  "Coerces x to a seq if it isn't one already"
  [x]
  (if (sequential? x)
    x
    (list x)))

(defn- deref-input-signals
  [signals query-id]
  (let [dereffed-signals (map-signals deref signals)]
    (cond
      (sequential? signals) (map deref signals)
      (map? signals) (map-vals deref signals)
      (deref? signals) (deref signals)
      :else (console :error "re-frame: in the reg-sub for" query-id ", the input-signals function returns:" signals))
    (trace/merge-trace! {:tags {:input-signals (doall (to-seq (map-signals reagent-id signals)))}})
    dereffed-signals))

(defn reg-sub
  "For a given `query-id`, register two functions: a `computation` function and an `input signals` function.

  During program execution, a call to `subscribe`, such as `(subscribe [:sub-id 3 "blue"])`,
  will create a new `:sub-id` node in the Signal Graph. And, at that time, re-frame
  needs to know how to create the node.   By calling `reg-sub`, you are registering
  "the template" or "the mechanism" by which nodes in the Signal Graph can be created.

  Repeating: calling `reg-sub` does not create a node. It only creates the template
  from which nodes can be created later.

  `reg-sub` arguments are:
    - a `query-id` (typically a namespaced keyword)
    - a function which returns the inputs required by this kind of node (3 variations of this)
    - a function which computes the value of this kind of node

  The`computation function` is always the last argument supplied and it is expected to have the signature:
    `(input-values, query-vector) -> a-value`

  When this computation function is called, `query-vector` will be what was passed as the first
  argument the `subscribe` causing the node to be created. So if the call was `(subscribe [:sub-id 3 "blue"])`
  then the `query-vector` supplied to the computaton function will be `[:sub-id 3 "blue"]`.

  The arguments supplied between the `query-id` and the `computation-function` can vary in 3 ways,
  but whatever is there will define the `input signals` part of the template, and this controls
  what `input-values` the `computation function` gets when it is called.

  `reg-sub` can be called in 3 ways, because there are 3 ways to supply input signals:

  1. No input signals given:
      ```clj
     (reg-sub
       :query-id
       a-computation-fn)   ;; (fn [db v]  ... a-value)
     ```

     In the absence of an `input-fn`, the node's input signal defaults to `app-db`
     and, as a result, the value within `app-db` (a map) is
     is given as the 1st argument when `a-computation-fn` is called.

  2. A signal function is explicitly supplied:
     ```clj
     (reg-sub
       :query-id
       signal-fn     ;; <-- here
       computation-fn)
     ```

     This is the most canonical and instructive of the three variations.

     When a node is created from the template, the `signal-fn` will be called and it
     is expected to return the input signal(s) as either a singleton, if there is only
     one, or a sequence if there are many, or a map with the signals as the values.

     The values from returned nominated signals will be supplied as the 1st argument to
     the `a-computation-fn` when it is called - and subject to what this `signal-fn` returns,
     this value will be either a singleton, sequence or map of them (paralleling
     the structure returned by the `signal-fn`).

     This example `signal-fn` returns a vector of input signals.
       ```clj
       (fn [query-vec dynamic-vec]
         [(subscribe [:a-sub])
          (subscribe [:b-sub])])
       ```
     The associated computation function must be written
     to expect a vector of values for its first argument:
       ```clj
       (fn [[a b] _]     ;; 1st argument is a seq of two values
         ....)
        ```

     If, on the other hand, the signal function was simpler and returned a singleton, like this:
        ```clj
        (fn [query-vec dynamic-vec]
          (subscribe [:a-sub]))
        ```
     then the associated computation function must be written to expect a single value
     as the 1st argument:
        ```clj
        (fn [a _]       ;; 1st argument is a single value
          ...)
        ```
  3. Syntax Sugar

     ```clj
     (reg-sub
       :a-b-sub
       :<- [:a-sub]
       :<- [:b-sub]
       (fn [[a b] [_]]    ;; 1st argument is a seq of two values
         {:a a :b b}))
     ```

     This 3rd variation is just syntactic sugar for the 2nd.  Instead of providing an
     `signals-fn` you provide one or more pairs of `:<-` and a subscription vector.

     If you supply only one pair a singleton will be supplied to the computation function,
     as if you had supplied a `signal-fn` returning only a single value:

     ```clj
     (reg-sub
       :a-sub
       :<- [:a-sub]
       (fn [a _]      ;; only one pair, so 1st argument is a single value
         ...))
     ```

  For further understanding, read `/docs`, and look at the detailed comments in
  /examples/todomvc/src/subs.cljs
  "
  [query-id & args]
  (let [computation-fn (last args)
        input-args     (butlast args) ;; may be empty, or one signal fn, or pairs of  :<- / vector
        err-header     (str "re-frame: reg-sub for " query-id ", ")
        inputs-fn      (case (count input-args)
                         ;; no `inputs` function provided - give the default
                         0 (fn
                             ([_] app-db)
                             ([_ _] app-db))

                         ;; a single `inputs` fn
                         1 (let [f (first input-args)]
                             (when-not (fn? f)
                               (console :error err-header "2nd argument expected to be an inputs function, got:" f))
                             f)

                         ;; one sugar pair
                         2 (let [[marker vec] input-args]
                             (when-not (= :<- marker)
                               (console :error err-header "expected :<-, got:" marker))
                             (fn inp-fn
                               ([_] (subscribe vec))
                               ([_ _] (subscribe vec))))

                         ;; multiple sugar pairs
                         (let [pairs   (partition 2 input-args)
                               markers (map first pairs)
                               vecs    (map last pairs)]
                           (when-not (and (every? #{:<-} markers) (every? vector? vecs))
                             (console :error err-header "expected pairs of :<- and vectors, got:" pairs))
                           (fn inp-fn
                             ([_] (map subscribe vecs))
                             ([_ _] (map subscribe vecs)))))]
    (register-handler
      kind
      query-id
      (fn subs-handler-fn
        ([db query-vec]
         (let [subscriptions (inputs-fn query-vec)
               reaction-id   (atom nil)
               reaction      (make-reaction
                               (fn []
                                 (trace/with-trace {:operation (first-in-vector query-vec)
                                                    :op-type   :sub/run
                                                    :tags      {:query-v    query-vec
                                                                :reaction   @reaction-id}}
                                                   (let [subscription (computation-fn (deref-input-signals subscriptions query-id) query-vec)]
                                                     (trace/merge-trace! {:tags {:value subscription}})
                                                     subscription))))]

           (reset! reaction-id (reagent-id reaction))
           reaction))
        ([db query-vec dyn-vec]
         (let [subscriptions (inputs-fn query-vec dyn-vec)
               reaction-id   (atom nil)
               reaction      (make-reaction
                               (fn []
                                 (trace/with-trace {:operation (first-in-vector query-vec)
                                                    :op-type   :sub/run
                                                    :tags      {:query-v   query-vec
                                                                :dyn-v     dyn-vec
                                                                :reaction  @reaction-id}}
                                                   (let [subscription (computation-fn (deref-input-signals subscriptions query-id) query-vec dyn-vec)]
                                                     (trace/merge-trace! {:tags {:value subscription}})
                                                     subscription))))]

           (reset! reaction-id (reagent-id reaction))
           reaction))))))

Update subs.cljc

Update subs.cljc