enhance snap

- remove subscription from event handler
- introduce snapping-points multimethod for tools
- explicitly update kd-tree
- fix snap on translate with locked direction

Author: sprocketc

.clj-kondo/metosin/malli-types-cljs/config.edn

@@ -77,6 +77,7 @@
    [:clicked-element {:optional true} [:or Element Handle]]
    [:copied-bounds {:optional true} Bounds]
    [:copied-elements {:optional true} [:* Element]]
+   [:kd-tree {:optional true} any?]
    [:re-pressed.core/keydown {:optional true} map?]])
 
 (def valid? (m/validator App))

src/renderer/app/db.cljs

@@ -8,6 +8,7 @@
    [renderer.element.handlers :as h]
    [renderer.history.handlers :refer [finalize]]
    [renderer.notification.events :as-alias notification.e]
+   [renderer.snap.handlers :as snap.h]
    [renderer.utils.bounds :as bounds]
    [renderer.utils.element :as element]
    [renderer.utils.extra :refer [partial-right]]
@@ -19,13 +20,15 @@
  ::select
  [(finalize "Select element")]
  (fn [db [_ id multiple]]
-   (h/select db id multiple)))
+   (-> (h/select db id multiple)
+       (snap.h/update-tree))))
 
 (rf/reg-event-db
  ::select-ids
  [(finalize "Select elements")]
  (fn [db [_ ids]]
-   (reduce (partial-right h/assoc-prop :selected true) (h/deselect db) ids)))
+   (-> (reduce (partial-right h/assoc-prop :selected true) (h/deselect db) ids)
+       (snap.h/update-tree))))
 
 (rf/reg-event-db
  ::toggle-prop

src/renderer/element/events.cljs

@@ -775,3 +775,8 @@
     (-> (add db svg)
         (collapse))))
 
+(defn snapping-points
+  [db els]
+  (let [options (-> db :snap :options)]
+    (reduce (fn [points el]
+              (into points (element/snapping-points el options))) [] els)))

src/renderer/element/handlers.cljs

@@ -69,3 +69,12 @@
   [el]
   (let [{{:keys [width height]} :attrs} el]
     (apply * (map units/unit->px [width height]))))
+
+(defmethod hierarchy/snapping-points ::hierarchy/box
+  [el]
+  (let [{{:keys [x y width height]} :attrs} el
+        [x y width height] (mapv units/unit->px [x y width height])]
+    [[x y]
+     [(+ x width) y]
+     [(+ x width) (+ y height)]
+     [x (+ y height)]]))

src/renderer/element/impl/box.cljs

@@ -27,8 +27,7 @@
 
 (defmethod hierarchy/render :canvas
   [el]
-  (let [_ @(rf/subscribe [::snap.s/in-viewport-tree]) ; TODO: Remove this.
-        child-elements @(rf/subscribe [::element.s/filter-visible (:children el)])
+  (let [child-elements @(rf/subscribe [::element.s/filter-visible (:children el)])
         viewbox-attr @(rf/subscribe [::frame.s/viewbox-attr])
         {:keys [width height]} @(rf/subscribe [::app.s/dom-rect])
         hovered-ids @(rf/subscribe [::element.s/hovered])
@@ -45,10 +44,8 @@
         state @(rf/subscribe [::tool.s/state])
         pointer-handler #(pointer/event-handler! % el)
         pivot-point @(rf/subscribe [::tool.s/pivot-point])
-        snapping-points @(rf/subscribe [::snap.s/points])
         snap-active @(rf/subscribe [::snap.s/active])
         nearest-neighbor @(rf/subscribe [::snap.s/nearest-neighbor])
-        debug @(rf/subscribe [::app.s/debug-info])
         transform-active (or (= tool :transform) (= primary-tool :transform))]
     [:svg#canvas {:on-pointer-up pointer-handler
                   :on-pointer-down pointer-handler
@@ -101,8 +98,9 @@
            (when (and transform-active pivot-point)
              [overlay/times pivot-point])])
 
-        (when (or (= tool :edit)
-                  (= primary-tool :edit))
+        (when (and (= state :idle)
+                   (or (= tool :edit)
+                       (= primary-tool :edit)))
           (for [el selected-elements]
             ^{:key (str (:id el) "-edit-points")}
             [:g
@@ -112,11 +110,6 @@
 
         [hierarchy/render temp-element]])
 
-     (when debug
-       [into [:g]
-        (for [snapping-point snapping-points]
-          [overlay/point-of-interest snapping-point])])
-
      (when (and snap-active nearest-neighbor)
        [overlay/times (:point nearest-neighbor)])
 

src/renderer/element/impl/container/canvas.cljs

@@ -96,3 +96,10 @@
   (let [{{:keys [x1 y1 x2 y2]} :attrs} el
         [x1 y1 x2 y2] (mapv units/unit->px [x1 y1 x2 y2])]
     [(min x1 x2) (min y1 y2) (max x1 x2) (max y1 y2)]))
+
+(defmethod hierarchy/snapping-points :line
+  [el]
+  (let [{{:keys [x1 y1 x2 y2]} :attrs} el
+        [x1 y1 x2 y2] (mapv units/unit->px [x1 y1 x2 y2])]
+    [[x1 y1]
+     [x2 y2]]))

src/renderer/element/impl/shape/line.cljs

@@ -40,20 +40,6 @@
  (fn [elements _]
    (filter :selected (vals elements))))
 
-(rf/reg-sub
- ::selected-descendant-ids
- (fn [db _]
-   (h/descendant-ids db)))
-
-(rf/reg-sub
- ::non-selected-visible
- :<- [::document.s/elements]
- :<- [::selected-descendant-ids]
- (fn [[elements selected-descendant-ids] _]
-   (filter #(and (not (:selected %))
-                 (not (contains? selected-descendant-ids (:id %)))
-                 (:visible %)) (vals elements))))
-
 (rf/reg-sub
  ::hovered
  :<- [::document.s/elements]

src/renderer/element/subs.cljs

@@ -3,8 +3,9 @@
    [clojure.core.matrix :as mat]
    [kdtree :as kdtree]
    [malli.core :as m]
-   [re-frame.core :as rf]
    [renderer.app.db :refer [App]]
+   [renderer.frame.db :refer [Viewbox]]
+   [renderer.frame.handlers :as frame.h]
    [renderer.snap.db :refer [SnapOption NearestNeighbor]]
    [renderer.snap.subs :as-alias snap.s]
    [renderer.tool.hierarchy :as tool.hierarchy]
@@ -17,52 +18,62 @@
     (update-in db [:snap :options] disj option)
     (update-in db [:snap :options] conj option)))
 
-(m/=> find-nearest-neighbors [:-> App [:sequential NearestNeighbor]])
-(defn find-nearest-neighbors
+(m/=> in-viewport-tree [:-> any? Viewbox any?])
+(defn in-viewport-tree
+  [tree [x y width height]]
+  (->> [[x (+ x width)] [y (+ y height)]]
+       (kdtree/interval-search tree)
+       (kdtree/build-tree)))
+
+(defn create-tree
+  [db]
+  (let [zoom (get-in db [:documents (:active-document db) :zoom])
+        pan (get-in db [:documents (:active-document db) :pan])
+        viewbox (frame.h/viewbox zoom pan (:dom-rect db))]
+    (-> (tool.hierarchy/snapping-points db)
+        (kdtree/build-tree)
+        (in-viewport-tree viewbox))))
+
+(m/=> nearest-neighbors [:-> App [:sequential NearestNeighbor]])
+(defn nearest-neighbors
   [db]
-  (let [tree @(rf/subscribe [::snap.s/in-viewport-tree])] ; FIXME: Subscription in event.
-    (map #(let [nearest-neighbor (kdtree/nearest-neighbor tree %)]
-            (when nearest-neighbor
-              (assoc nearest-neighbor :base-point %)))
-         (tool.hierarchy/snapping-bases db))))
+  (map #(when-let [nneighbor (kdtree/nearest-neighbor (:kd-tree db) %)]
+          (assoc nneighbor :base-point %))
+       (tool.hierarchy/snapping-bases db)))
 
-(m/=> find-nearest-neighbor [:-> App [:maybe NearestNeighbor]])
-(defn find-nearest-neighbor
+(m/=> nearest-neighbor [:-> App [:maybe NearestNeighbor]])
+(defn nearest-neighbor
   [db]
-  (let [threshold (-> db :snap :threshold)
-        nearest-neighbors (find-nearest-neighbors db)
-        threshold (/ threshold (get-in db [:documents (:active-document db) :zoom]))
-        nearest-neighbor (reduce
-                          (fn [nearest-neighbor neighbor]
-                            (if (< (:dist-squared neighbor)
-                                   (:dist-squared nearest-neighbor))
-                              neighbor
-                              nearest-neighbor))
-                          (first nearest-neighbors)
-                          (rest nearest-neighbors))]
-    (when (< (:dist-squared nearest-neighbor) (Math/pow threshold 2))
-      nearest-neighbor)))
+  (when (-> db :snap :active)
+    (let [threshold (-> db :snap :threshold)
+          nneighbors (nearest-neighbors db)
+          threshold (/ threshold (get-in db [:documents (:active-document db) :zoom]))
+          nneighbor (apply min-key :dist-squared nneighbors)]
+      (when (< (:dist-squared nneighbor) (Math/pow threshold 2))
+        nneighbor))))
 
-(m/=> update-nearest-neighbor [:-> App App])
 (defn update-nearest-neighbor
   [db]
-  (let [nearest-neighbor (find-nearest-neighbor db)]
-    (cond-> db
-      :always
-      (dissoc :nearest-neighbor)
+  (assoc db :nearest-neighbor (nearest-neighbor db)))
 
-      (and (-> db :snap :active) nearest-neighbor)
-      (assoc :nearest-neighbor nearest-neighbor))))
+(defn update-tree
+  [db]
+  (cond-> db
+    (-> db :snap :active)
+    (assoc :kd-tree (create-tree db))))
 
 (m/=> nearest-delta [:-> App Vec2D])
 (defn nearest-delta
   [db]
-  (let [{:keys [point base-point]} (:nearest-neighbor db)]
-    (mat/sub point base-point)))
+  (if (:nearest-neighbor db)
+    (let [{:keys [point base-point]} (:nearest-neighbor db)]
+      (mat/sub point base-point))
+    [0 0]))
 
 (defn snap-with
   [db f & more]
   (let [db (update-nearest-neighbor db)]
     (if (:nearest-neighbor db)
       (apply f db (nearest-delta db) more)
       db)))
+

src/renderer/snap/handlers.cljs

@@ -1,10 +1,8 @@
 (ns renderer.snap.subs
   (:require
-   [kdtree :as kdtree]
    [re-frame.core :as rf]
    [renderer.element.subs :as-alias element.s]
-   [renderer.frame.subs :as-alias frame.s]
-   [renderer.utils.element :as utils.el]))
+   [renderer.frame.subs :as-alias frame.s]))
 
 (rf/reg-sub
  ::snap
@@ -23,26 +21,3 @@
 (rf/reg-sub
  ::nearest-neighbor
  :-> :nearest-neighbor)
-
-(rf/reg-sub
- ::points
- :<- [::element.s/non-selected-visible]
- :<- [::active]
- :<- [::options]
- (fn [[non-selected-visible-elements active options] _]
-   (when active
-     (reduce (fn [points el] (into points (utils.el/snapping-points el options)))
-             [] non-selected-visible-elements))))
-
-(rf/reg-sub
- ::tree
- :<- [::points]
- kdtree/build-tree)
-
-(rf/reg-sub
- ::in-viewport-tree
- :<- [::frame.s/viewbox]
- :<- [::tree]
- (fn [[[x y width height] tree] _]
-   (kdtree/build-tree (kdtree/interval-search tree [[x (+ x width)]
-                                                    [y (+ y height)]]))))

src/renderer/snap/subs.cljs

@@ -28,14 +28,6 @@
   [db explanation]
   (assoc db :explanation explanation))
 
-(m/=> activate [:-> App Tool App])
-(defn activate
-  [db tool]
-  (-> db
-      (hierarchy/deactivate)
-      (assoc :tool tool)
-      (hierarchy/activate)))
-
 (m/=> set-state [:-> App State App])
 (defn set-state
   [db state]
@@ -46,6 +38,17 @@
   [db cursor]
   (assoc db :cursor cursor))
 
+(m/=> activate [:-> App Tool App])
+(defn activate
+  [db tool]
+  (-> db
+      (hierarchy/deactivate)
+      (assoc :tool tool)
+      (set-state :idle)
+      (set-cursor "default")
+      (dissoc :drag :pointer-offset :clicked-element)
+      (hierarchy/activate)))
+
 (m/=> pointer-delta [:-> App Vec2D])
 (defn pointer-delta
   [db]
@@ -86,7 +89,8 @@
   [db e now]
   (let [{:keys [pointer-offset tool dom-rect drag primary-tool drag-threshold nearest-neighbor]} db
         {:keys [button buttons pointer-pos]} e
-        adjusted-pointer-pos (frame.h/adjust-pointer-pos db pointer-pos)]
+        adjusted-pointer-pos (frame.h/adjust-pointer-pos db pointer-pos)
+        db (snap.h/update-nearest-neighbor db)]
     (case (:type e)
       "pointermove"
       (-> (if pointer-offset
@@ -104,7 +108,6 @@
                 (hierarchy/drag e))
               db)
             (hierarchy/pointer-move db e))
-          (snap.h/update-nearest-neighbor)
           (assoc :pointer-pos pointer-pos
                  :adjusted-pointer-pos adjusted-pointer-pos))
 
@@ -138,8 +141,7 @@
             (dissoc :primary-tool))
 
         :always
-        (-> (dissoc :pointer-offset :drag)
-            (update :snap dissoc :nearest-neighbor)))
+        (dissoc :pointer-offset :drag :nearest-neighbor))
 
       db)))
 
@@ -185,8 +187,7 @@
   [db]
   (cond-> db
     :always
-    (-> (dissoc :drag :pointer-offset :clicked-element)
-        (hierarchy/activate (:tool db))
+    (-> (activate (:tool db))
         (dissoc-temp)
         (history.h/swap))
 

src/renderer/tool/handlers.cljs

@@ -10,12 +10,13 @@
 (defmulti key-up (fn [db _e] (:tool db)))
 (defmulti key-down (fn [db _e] (:tool db)))
 (defmulti snapping-bases (fn [db _e] (:tool db)))
+(defmulti snapping-points (fn [db _e] (:tool db)))
 (defmulti activate :tool)
 (defmulti deactivate :tool)
-(defmulti properties "Returns the properties of the tool." keyword)
+(defmulti properties "Returns the properties of the tool." identity)
 (defmulti help "Returns the status bar help text." (fn [tool state] [tool state]))
 
-(defmulti right-panel keyword)
+(defmulti right-panel identity)
 
 (defmethod pointer-down :default [db _e] db)
 (defmethod pointer-up :default [db _e] db)
@@ -26,10 +27,11 @@
 (defmethod key-down :default [db _e] db)
 (defmethod drag :default [db e] (pointer-move db e))
 (defmethod drag-end :default [db e] (pointer-up db e))
-(defmethod activate :default [db] (assoc db :cursor "default"))
-(defmethod deactivate :default [db] (assoc db :cursor "default"))
+(defmethod activate :default [db] db)
+(defmethod deactivate :default [db] db)
 (defmethod properties :default [])
 (defmethod snapping-bases :default [])
+(defmethod snapping-points :default [])
 (defmethod help :default [_tool _state] "")