adds a history slider

examples/geometry/src/geometry/components.cljs

@@ -19,22 +19,31 @@
    :stroke "black"
    :stroke-width 2})
 
+(def rect-defaults
+  {:stroke "black"
+   :width 10
+   :height 30})
+
 (defn drag-move-fn [on-drag]
   (fn [evt]
     (on-drag (.-clientX evt) (.-clientY evt))))
 
-(defn drag-end-fn [drag-move drag-end]
+(defn drag-end-fn [drag-move drag-end on-end]
   (fn [evt]
     (events/unlisten js/window EventType.MOUSEMOVE drag-move)
-    (events/unlisten js/window EventType.MOUSEUP @drag-end)))
+    (events/unlisten js/window EventType.MOUSEUP @drag-end)
+    (on-end)))
 
-(defn dragging [on-drag]
-  (let [drag-move (drag-move-fn on-drag)
-        drag-end-atom (atom nil)
-        drag-end (drag-end-fn drag-move drag-end-atom)]
-    (reset! drag-end-atom drag-end)
-    (events/listen js/window EventType.MOUSEMOVE drag-move)
-    (events/listen js/window EventType.MOUSEUP drag-end)))
+(defn dragging
+  ([on-drag] (dragging on-drag (fn []) (fn [])))
+  ([on-drag on-start on-end]
+   (let [drag-move (drag-move-fn on-drag)
+         drag-end-atom (atom nil)
+         drag-end (drag-end-fn drag-move drag-end-atom on-end)]
+     (on-start)
+     (reset! drag-end-atom drag-end)
+     (events/listen js/window EventType.MOUSEMOVE drag-move)
+     (events/listen js/window EventType.MOUSEUP drag-end))))
 
 (defn point [{:keys [on-drag]} p]
   [:circle 
@@ -61,3 +70,9 @@
           {:cx (x c)
            :cy (y c)
            :r (dist c r)})])
+
+(defn rect [{:keys [on-drag on-start on-end]} c]
+  [:rect (merge rect-defaults
+                {:on-mouse-down #(dragging on-drag on-start on-end)
+                 :x (x c)
+                 :y (- (y c) 15)})])

examples/geometry/src/geometry/core.cljs

@@ -14,19 +14,55 @@
     :c (g/point 250 250)
     :p (g/point 250 300)}))
 
+(defonce slider
+  (r/atom
+   {:handle (g/point 500 50)
+    :history []}))
+
+(defn record-state [_ _ _ s]
+  (swap! slider (fn [{:keys [history] :as coll}]
+                  (assoc coll :history (conj history s)))))
+
+(defn start-recording-history []
+  (let [history (:history @slider)]
+    (add-watch points :record record-state)))
+
+(defn stop-recording-history []
+  (remove-watch points :record))
+
+(add-watch points :record record-state)
+
+(defn get-bcr [svg-root]
+  (-> svg-root
+      r/dom-node
+      .getBoundingClientRect))
+
 (defn move-point [svg-root p]
   (fn [x y]
-    (let [bcr (-> svg-root
-                  r/dom-node
-                  .getBoundingClientRect)]
+    (let [bcr (get-bcr svg-root)]
       (swap! points assoc p (g/point (- x (.-left bcr)) (- y (.-top bcr)))))))
 
+(defn move-slider [svg-root p]
+  (fn [x y]
+    (let [new-x (-> (- x (.-left (get-bcr svg-root)))
+                    (min 500)
+                    (max 100))
+          position (/ (- new-x 100)
+                      (- 500 100))
+          history (:history @slider)]
+      (swap! slider assoc p (g/point new-x 50))
+      (reset! points (nth history (int (* (dec (count history)) position)))))))
+
 (defn root [svg-root]
   (let [{:keys [p1 p2 p3 p c]} @points]
     [:g
      [c/triangle p1 p2 p3]
      [c/circle p c]
      [c/segment p c]
+     [c/segment (g/point 100 50) (g/point 500 50)]
+     [c/rect {:on-drag (move-slider svg-root :handle)
+              :on-start stop-recording-history
+              :on-end start-recording-history} (:handle @slider)]
      [c/point {:on-drag (move-point svg-root :c)} c]
      [c/point {:on-drag (move-point svg-root :p)} p]
      [c/point {:on-drag (move-point svg-root :p1)} p1]
@@ -41,7 +77,7 @@
    [:text {:style {:-webkit-user-select "none"
                    :-moz-user-select "none"}
            :x 20 :y 20 :font-size 20}
-    "The points are draggable"]
+    "The points are draggable and the slider controls history"]
    [root (r/current-component)]])
 
 (defn by-id [id]