✨ Improved make curve options

common/app/common/geom/point.cljc

@@ -213,12 +213,12 @@
   (let [v-length (length v)]
     (divide v (point v-length v-length))))
 
-(defn project [v1 v2]
+(defn project
+  "V1 perpendicular projection on vector V2"
+  [v1 v2]
   (let [v2-unit (unit v2)
-        scalar-projection (dot v1 (unit v2))]
-    (multiply
-     v2-unit
-     (point scalar-projection scalar-projection))))
+        scalar-proj (dot v1 v2-unit)]
+    (scale v2-unit scalar-proj)))
 
 (defn center-points
   "Centroid of a group of points"
@@ -264,7 +264,34 @@
               (scale v))]
     (add p1 v)))
 
+
+(defn rotate
+  "Rotates the point around center with an angle"
+  [{px :x py :y} {cx :x cy :y} angle]
+  (let [angle (mth/radians angle)
+
+        x (+ (* (mth/cos angle) (- px cx))
+             (* (mth/sin angle) (- py cy) -1)
+             cx)
+
+        y (+ (* (mth/sin angle) (- px cx))
+             (* (mth/cos angle) (- py cy))
+             cy)]
+    (point x y)))
+
+
+(defn scale-from
+  "Moves a point in the vector that creates with center with a scale
+  value"
+  [point center value]
+  (add point
+       (-> (to-vec center point)
+           (unit)
+           (scale value))))
+
+
 ;; --- Debug
 
 (defmethod pp/simple-dispatch Point [obj] (pr obj))
 
+

frontend/src/app/main/data/workspace/path/drawing.cljs

@@ -58,54 +58,51 @@
               (update-in (st/get-path state) helpers/append-node position last-point prev-handler))
           state)))))
 
-(defn start-drag-handler []
-  (ptk/reify ::start-drag-handler
-    ptk/UpdateEvent
-    (update [_ state]
-      (let [content (get-in state (st/get-path state :content))
-            index (dec (count content))
-            command (get-in state (st/get-path state :content index :command))
+(defn drag-handler
+  ([{:keys [x y alt? shift?] :as position}]
+   (drag-handler nil nil :c1 position))
 
-            make-curve
-            (fn [command]
-              (let [params (upc/make-curve-params
-                            (get-in content [index :params])
-                            (get-in content [(dec index) :params]))]
-                (-> command
-                    (assoc :command :curve-to :params params))))]
+  ([position index prefix {:keys [x y alt? shift?]}]
+   (ptk/reify ::drag-handler
+     ptk/UpdateEvent
+     (update [_ state]
+       (let [id (st/get-path-id state)
+             content (get-in state (st/get-path state :content))
 
-        (cond-> state
-          (= command :line-to)
-          (update-in (st/get-path state :content index) make-curve))))))
+             index (or index (count content))
+             prefix (or prefix :c1)
+             position (or position (upc/command->point (nth content (dec index))))
 
-(defn drag-handler [{:keys [x y alt? shift?]}]
-  (ptk/reify ::drag-handler
-    ptk/UpdateEvent
-    (update [_ state]
-      (let [id (st/get-path-id state)
-            shape (get-in state (st/get-path state))
-            content (:content shape)
-            index (dec (count content))
-            node-position (upc/command->point (nth content index))
-            handler-position (cond-> (gpt/point x y)
-                               shift? (helpers/position-fixed-angle node-position))
-            {dx :x dy :y} (gpt/subtract handler-position node-position)
-            match-opposite? (not alt?)
-            modifiers (helpers/move-handler-modifiers content (inc index) :c1 match-opposite? dx dy)]
-        (-> state
-            (update-in [:workspace-local :edit-path id :content-modifiers] merge modifiers)
-            (assoc-in [:workspace-local :edit-path id :prev-handler] handler-position)
-            (assoc-in [:workspace-local :edit-path id :drag-handler] handler-position))))))
+             old-handler (helpers/handler->point content index prefix)
+
+             handler-position (cond-> (gpt/point x y)
+                                shift? (helpers/position-fixed-angle position))
+
+             {dx :x dy :y} (if (some? old-handler)
+                             (gpt/add (gpt/to-vec old-handler position)
+                                      (gpt/to-vec position handler-position))
+                             (gpt/to-vec position handler-position))
+
+             match-opposite? (not alt?)
+
+             modifiers (helpers/move-handler-modifiers content index prefix match-opposite? match-opposite? dx dy)]
+         (-> state
+             (update-in [:workspace-local :edit-path id :content-modifiers] merge modifiers)
+             (assoc-in [:workspace-local :edit-path id :drag-handler] handler-position)))))))
 
 (defn finish-drag []
   (ptk/reify ::finish-drag
     ptk/UpdateEvent
     (update [_ state]
       (let [id (st/get-path-id state)
+
             modifiers (get-in state [:workspace-local :edit-path id :content-modifiers])
+            content (-> (get-in state (st/get-path state :content))
+                        (upc/apply-content-modifiers modifiers))
+
             handler (get-in state [:workspace-local :edit-path id :drag-handler])]
         (-> state
-            (update-in (st/get-path state :content) upc/apply-content-modifiers modifiers)
+            (assoc-in (st/get-path state :content) content)
             (update-in [:workspace-local :edit-path id] dissoc :drag-handler)
             (update-in [:workspace-local :edit-path id] dissoc :content-modifiers)
             (assoc-in  [:workspace-local :edit-path id :prev-handler] handler)
@@ -135,17 +132,21 @@
             content (get-in state (st/get-path state :content))
             snap-toggled (get-in state [:workspace-local :edit-path id :snap-toggled])
             points (upg/content->points content)
+
+            handlers (-> (upc/content->handlers content)
+                         (get position))
+
+            [idx prefix] (when (= (count handlers) 1) (first handlers))
             
             drag-events-stream
             (->> (streams/position-stream snap-toggled points)
                  (rx/take-until stop-stream)
-                 (rx/map #(drag-handler %)))]
+                 (rx/map #(drag-handler position idx prefix %)))]
 
         (rx/concat
          (rx/of (add-node position))
          (streams/drag-stream
           (rx/concat
-           (rx/of (start-drag-handler))
            drag-events-stream
            (rx/of (finish-drag))
            (rx/of (close-path-drag-end))))
@@ -180,7 +181,6 @@
          (rx/of (add-node position))
          (streams/drag-stream
           (rx/concat
-           (rx/of (start-drag-handler))
            drag-events
            (rx/of (finish-drag)))))))))
 
@@ -204,7 +204,6 @@
      (rx/of (add-node down-event))
      (streams/drag-stream
       (rx/concat
-       (rx/of (start-drag-handler))
        drag-events
        (rx/of (finish-drag)))))))
 

frontend/src/app/main/data/workspace/path/edition.cljs

@@ -25,37 +25,23 @@
    [beicon.core :as rx]
    [potok.core :as ptk]))
 
-(defn modify-point [index prefix dx dy]
-  (ptk/reify ::modify-point
-    ptk/UpdateEvent
-    (update [_ state]
-      (let [id (get-in state [:workspace-local :edition])
-            [cx cy] (if (= prefix :c1) [:c1x :c1y] [:c2x :c2y])]
-        (-> state
-            (update-in [:workspace-local :edit-path id :content-modifiers (inc index)] assoc
-                       :c1x dx :c1y dy)
-            (update-in [:workspace-local :edit-path id :content-modifiers index] assoc
-                       :x dx :y dy :c2x dx :c2y dy))))))
-
 (defn modify-handler [id index prefix dx dy match-opposite?]
   (ptk/reify ::modify-handler
     ptk/UpdateEvent
     (update [_ state]
+
       (let [content (get-in state (st/get-path state :content))
+
+            modifiers (helpers/move-handler-modifiers content index prefix false match-opposite? dx dy)
             [cx cy] (if (= prefix :c1) [:c1x :c1y] [:c2x :c2y])
-            [ocx ocy] (if (= prefix :c1) [:c2x :c2y] [:c1x :c1y])
             point (gpt/point (+ (get-in content [index :params cx]) dx)
                              (+ (get-in content [index :params cy]) dy))
-            opposite-index (upc/opposite-index content index prefix)]
-        (cond-> state
-          :always
-          (-> (update-in [:workspace-local :edit-path id :content-modifiers index] assoc
-                         cx dx cy dy)
-              (assoc-in [:workspace-local :edit-path id :moving-handler] point))
 
-          (and match-opposite? opposite-index)
-          (update-in [:workspace-local :edit-path id :content-modifiers opposite-index] assoc
-                     ocx (- dx) ocy (- dy)))))))
+            ]
+
+        (-> state
+            (update-in [:workspace-local :edit-path id :content-modifiers] merge modifiers)
+            (assoc-in [:workspace-local :edit-path id :moving-handler] point))))))
 
 (defn apply-content-modifiers []
   (ptk/reify ::apply-content-modifiers
@@ -174,15 +160,9 @@
             content (get-in state (st/get-path state :content))
             points (upg/content->points content)
 
-            opposite-index   (upc/opposite-index content index prefix)
-            opposite-prefix  (if (= prefix :c1) :c2 :c1)
-            opposite-handler (-> content (get opposite-index) (upc/get-handler opposite-prefix))
-
             point (-> content (get (if (= prefix :c1) (dec index) index)) (upc/command->point))
             handler (-> content (get index) (upc/get-handler prefix))
 
-            current-distance (when opposite-handler (gpt/distance (upg/opposite-handler point handler) opposite-handler))
-            match-opposite? (and opposite-handler (mth/almost-zero? current-distance))
             snap-toggled (get-in state [:workspace-local :edit-path id :snap-toggled])]
 
         (streams/drag-stream
@@ -199,7 +179,7 @@
                      prefix
                      (+ start-delta-x (- (:x pos) (:x start-point)))
                      (+ start-delta-y (- (:y pos) (:y start-point)))
-                     (and (not alt?) match-opposite?))))))
+                     (not alt?))))))
           (rx/concat (rx/of (apply-content-modifiers)))))))))
 
 (declare stop-path-edit)

frontend/src/app/main/data/workspace/path/helpers.cljs

@@ -106,15 +106,88 @@
         (update :content (fnil conj []) command)
         (update-selrect))))
 
+(defn prefix->coords [prefix]
+  (case prefix
+    :c1 [:c1x :c1y]
+    :c2 [:c2x :c2y]
+    nil))
+
+(defn handler->point [content index prefix]
+  (when (and (some? index)
+             (some? prefix)
+             (contains? content index))
+    (let [[cx cy :as coords] (prefix->coords prefix)]
+      (if (= :curve-to (get-in content [index :command]))
+        (gpt/point (get-in content [index :params cx])
+                   (get-in content [index :params cy]))
+
+        (gpt/point (get-in content [index :params :x])
+                   (get-in content [index :params :y]))))))
+
+(defn handler->node [content index prefix]
+  (if (= prefix :c1)
+    (upc/command->point (get content (dec index)))
+    (upc/command->point (get content index))))
+
+(defn angle-points [common p1 p2]
+  (mth/abs
+   (gpt/angle-with-other
+    (gpt/to-vec common p1)
+    (gpt/to-vec common p2))))
+
+(defn calculate-opposite-delta [node handler opposite match-angle? match-distance? dx dy]
+  (when (and (some? handler) (some? opposite))
+    (let [;; To match the angle, the angle should be matching (angle between points 180deg)
+          angle-handlers (angle-points node handler opposite)
+
+          match-angle? (and match-angle? (<= (mth/abs (- 180 angle-handlers) ) 0.1))
+
+          ;; To match distance the distance should be matching
+          match-distance? (and match-distance? (mth/almost-zero? (- (gpt/distance node handler)
+                                                                    (gpt/distance node opposite))))
+
+          new-handler (-> handler (update :x + dx) (update :y + dy))
+
+          v1 (gpt/to-vec node handler)
+          v2 (gpt/to-vec node new-handler)
+
+          delta-angle (gpt/angle-with-other v1 v2)
+          delta-sign (if (> (* (:y v1) (:x v2)) (* (:x v1) (:y v2))) -1 1)
+
+          distance-scale (/ (gpt/distance node handler)
+                            (gpt/distance node new-handler))
+
+          new-opposite (cond-> opposite
+                         match-angle?
+                         (gpt/rotate node (* delta-sign delta-angle))
+
+                         match-distance?
+                         (gpt/scale-from node distance-scale))]
+      [(- (:x new-opposite) (:x opposite))
+       (- (:y new-opposite) (:y opposite))])))
+
 (defn move-handler-modifiers
-  [content index prefix match-opposite? dx dy]
-  (let [[cx cy] (if (= prefix :c1) [:c1x :c1y] [:c2x :c2y])
-        [ocx ocy] (if (= prefix :c1) [:c2x :c2y] [:c1x :c1y])
-        opposite-index (upc/opposite-index content index prefix)]
+  [content index prefix match-distance? match-angle? dx dy]
 
-    (cond-> {}
-      :always
-      (update index assoc cx dx cy dy)
+  (let [[cx cy] (prefix->coords prefix)
+        [op-idx op-prefix] (upc/opposite-index content index prefix)
 
-      (and match-opposite? opposite-index)
-      (update opposite-index assoc ocx (- dx) ocy (- dy)))))
+        node (handler->node content index prefix)
+        handler (handler->point content index prefix)
+        opposite (handler->point content op-idx op-prefix)
+
+        [ocx ocy] (prefix->coords op-prefix)
+        [odx ody] (calculate-opposite-delta node handler opposite match-angle? match-distance? dx dy)
+
+        hnv (if (some? handler)
+              (gpt/to-vec node (-> handler (update :x + dx) (update :y + dy)))
+              (gpt/point dx dy))]
+
+    (-> {}
+        (update index assoc cx dx cy dy)
+
+        (cond-> (and (some? op-idx) (not= opposite node))
+          (update op-idx assoc ocx odx ocy ody)
+
+          (and (some? op-idx) (= opposite node) match-distance? match-angle?)
+          (update op-idx assoc ocx (- (:x hnv)) ocy (- (:y hnv)))))))

frontend/src/app/main/data/workspace/path/streams.cljs

@@ -88,7 +88,9 @@
               (gpt/add position snap))
             position))]
     (->> ms/mouse-position
-         (rx/map check-path-snap))))
+         (rx/map check-path-snap)
+         (rx/with-latest merge (->> ms/mouse-position-shift (rx/map #(hash-map :shift? %))))
+         (rx/with-latest merge (->> ms/mouse-position-alt (rx/map #(hash-map :alt? %)))))))
 
 (defn position-stream
   [snap-toggled points]

frontend/src/app/main/ui/shapes/path.cljs

@@ -39,4 +39,3 @@
                                :base-props props
                                :elem-name "path"}])))
 
-

frontend/src/app/util/path/commands.cljs

@@ -53,22 +53,43 @@
     :c2x (:x h2)
     :c2y (:y h2)}))
 
-(defn make-curve-to [to h1 h2]
+(defn update-curve-to
+  [command h1 h2]
+  (-> command
+      (assoc :command :curve-to)
+      (assoc-in [:params :c1x] (:x h1))
+      (assoc-in [:params :c1y] (:y h1))
+      (assoc-in [:params :c2x] (:x h2))
+      (assoc-in [:params :c2y] (:y h2))))
+
+(defn make-curve-to
+  [to h1 h2]
   {:command :curve-to
    :relative false
    :params (make-curve-params to h1 h2)})
 
-(defn apply-content-modifiers [content modifiers]
+(defn update-handler
+  [command prefix point]
+  (let [[cox coy] (if (= prefix :c1) [:c1x :c1y] [:c2x :c2y])]
+    (-> command
+        (assoc-in [:params cox] (:x point))
+        (assoc-in [:params coy] (:y point)))))
+
+(defn apply-content-modifiers
+  "Apply to content a map with point translations"
+  [content modifiers]
   (letfn [(apply-to-index [content [index params]]
             (if (contains? content index)
               (cond-> content
                 (and
                  (or (:c1x params) (:c1y params) (:c2x params) (:c2y params))
-                 (= :line-to (get-in content [index :params :command])))
+                 (= :line-to (get-in content [index :command])))
+
                 (-> (assoc-in [index :command] :curve-to)
-                    (assoc-in [index :params] :curve-to) (make-curve-params
-                                                          (get-in content [index :params])
-                                                          (get-in content [(dec index) :params])))
+                    (assoc-in [index :params]
+                              (make-curve-params
+                               (get-in content [index :params])
+                               (get-in content [(dec index) :params]))))
 
                 (:x params) (update-in [index :params :x] + (:x params))
                 (:y params) (update-in [index :params :y] + (:y params))
@@ -117,6 +138,7 @@
        (mapv (fn [[index _]] index))))
 
 (defn handler-indices
+  "Return an index where the key is the positions and the values the handlers"
   [content point]
   (->> (d/with-prev content)
        (d/enumerate)
@@ -132,16 +154,24 @@
 (defn opposite-index
   "Calculate sthe opposite index given a prefix and an index"
   [content index prefix]
+
   (let [point (if (= prefix :c2)
                 (command->point (nth content index))
                 (command->point (nth content (dec index))))
 
-        handlers (-> (content->handlers content)
-                     (get point))
+        point->handlers (content->handlers content)
 
-        opposite-prefix (if (= prefix :c1) :c2 :c1)]
-    (when (<= (count handlers) 2)
+        handlers (->> point
+                      (point->handlers )
+                      (filter (fn [[ci cp]] (and (not= index ci) (not= prefix cp)) )))]
+
+    (when (= (count handlers) 1)
       (->> handlers
-           (d/seek (fn [[index prefix]] (= prefix opposite-prefix)))
-           (first)))))
+           first))))
 
+
+(defn get-commands
+  "Returns the commands involving a point with its indices"
+  [content point]
+  (->> (d/enumerate content)
+       (filterv (fn [[idx cmd]] (= (command->point cmd) point)))))

frontend/src/app/util/path/tools.cljs

@@ -54,59 +54,113 @@
       (reduce change-content $ handlers)
       (remove-line-curves $))))
 
+(defn line->curve
+  [from-p cmd]
+
+  (let [to-p (upc/command->point cmd)
+
+        v (gpt/to-vec from-p to-p)
+        d (gpt/distance from-p to-p)
+
+        dv1 (-> (gpt/normal-left v)
+                (gpt/scale (/ d 3)))
+
+        h1 (gpt/add from-p dv1)
+
+        dv2 (-> (gpt/to-vec to-p h1)
+                (gpt/unit)
+                (gpt/scale (/ d 3)))
+
+        h2 (gpt/add to-p dv2)]
+    (-> cmd
+        (assoc :command :curve-to)
+        (assoc-in [:params :c1x] (:x h1))
+        (assoc-in [:params :c1y] (:y h1))
+        (assoc-in [:params :c2x] (:x h2))
+        (assoc-in [:params :c2y] (:y h2)))))
+
 (defn make-curve-point
   "Changes the content to make the point a 'curve'. The handlers will be positioned
   in the same vector that results from te previous->next points but with fixed length."
   [content point]
-  (let [content-next (d/enumerate (d/with-prev-next content))
 
-        make-curve
-        (fn [command previous]
-          (if (= :line-to (:command command))
-            (let [cur-point (upc/command->point command)
-                  pre-point (upc/command->point previous)]
-              (-> command
-                  (assoc :command :curve-to)
-                  (assoc :params (upc/make-curve-params cur-point pre-point))))
-            command))
+  (let [make-curve-cmd (fn [cmd h1 h2]
+                         (-> cmd
+                             (update :params assoc
+                                     :c1x (:x h1) :c1y (:y h1)
+                                     :c2x (:x h2) :c2y (:y h2))))
 
-        update-handler
-        (fn [command prefix handler]
-          (if (= :curve-to (:command command))
-            (let [cx (d/prefix-keyword prefix :x)
-                  cy (d/prefix-keyword prefix :y)]
-              (-> command
-                  (assoc-in [:params cx] (:x handler))
-                  (assoc-in [:params cy] (:y handler))))
-            command))
+        indices (upc/point-indices content point)
+        vectors (->> indices (mapv (fn [index]
+                                     (let [cmd (nth content index)
+                                           prev-i (dec index)
+                                           prev (when (not (= :move-to (:command cmd)))
+                                                  (get content prev-i))
+                                           next-i (inc index)
+                                           next (get content next-i)
 
-        calculate-vector
-        (fn [point next prev]
-          (let [base-vector (if (or (nil? next) (nil? prev) (= next prev))
-                              (-> (gpt/to-vec point (or next prev))
-                                  (gpt/normal-left))
-                              (gpt/to-vec next prev))]
-            (-> base-vector
-                (gpt/unit)
-                (gpt/multiply (gpt/point 100)))))
+                                           next (when (not (= :move-to (:command next)))
+                                                  next)]
+                                       (hash-map :index index
+                                                 :prev-i (when (some? prev) prev-i)
+                                                 :prev-c prev
+                                                 :prev-p (upc/command->point prev)
+                                                 :next-i (when (some? next) next-i)
+                                                 :next-c next
+                                                 :next-p (upc/command->point next)
+                                                 :command cmd)))))
 
-        redfn (fn [content [index [command prev next]]]
-                (if (= point (upc/command->point command))
-                  (let [prev-point (if (= :move-to (:command command)) nil (upc/command->point prev))
-                        next-point (if (= :move-to (:command next)) nil (upc/command->point next))
-                        handler-vector (calculate-vector point next-point prev-point)
-                        handler (gpt/add point handler-vector)
-                        handler-opposite (gpt/add point (gpt/negate handler-vector))]
-                    (-> content
-                        (d/update-when index make-curve prev)
-                        (d/update-when index update-handler :c2 handler)
-                        (d/update-when (inc index) make-curve command)
-                        (d/update-when (inc index) update-handler :c1 handler-opposite)))
 
-                  content))]
-    (as-> content $
-      (reduce redfn $ content-next)
-      (remove-line-curves $))))
+        points (->> vectors (mapcat #(vector (:next-p %) (:prev-p %))) (remove nil?) (into #{}))]
+
+    (cond
+      (= (count points) 2)
+      ;;
+      (let [v1 (gpt/to-vec (first points) point)
+            v2 (gpt/to-vec (first points) (second points))
+            vp (gpt/project v1 v2)
+            vh (gpt/subtract v1 vp)
+
+            add-curve
+            (fn [content {:keys [index prev-p next-p next-i]}]
+              (let [cur-cmd (get content index)
+                    next-cmd (get content next-i)
+
+                    ;; New handlers for prev-point and next-point
+                    prev-h (when (some? prev-p) (gpt/add prev-p vh))
+                    next-h (when (some? next-p) (gpt/add next-p vh))
+
+                    ;; Correct 1/3 to the point improves the curve
+                    prev-correction (when (some? prev-h) (gpt/scale (gpt/to-vec prev-h point) (/ 1 3)))
+                    next-correction (when (some? next-h) (gpt/scale (gpt/to-vec next-h point) (/ 1 3)))
+
+                    prev-h (when (some? prev-h) (gpt/add prev-h prev-correction))
+                    next-h (when (some? next-h) (gpt/add next-h next-correction))
+                    ]
+                (cond-> content
+                  (and (= :line-to (:command cur-cmd)) (some? prev-p))
+                  (update index upc/update-curve-to prev-p prev-h)
+
+                  (and (= :line-to (:command next-cmd)) (some? next-p))
+                  (update next-i upc/update-curve-to next-h next-p)
+
+                  (and (= :curve-to (:command cur-cmd)) (some? prev-p))
+                  (update index upc/update-handler :c2 prev-h)
+
+                  (and (= :curve-to (:command next-cmd)) (some? next-p))
+                  (update next-i upc/update-handler :c1 next-h))))]
+        (->> vectors (reduce add-curve content)))
+
+      :else
+      (let [add-curve
+            (fn [content {:keys [index command prev-p next-c next-i]}]
+              (cond-> content
+                (and (= :line-to (:command command)))
+                (update index #(line->curve prev-p %))
+
+                (and (= :line-to (:command next-c)))
+                (update next-i #(line->curve point %))))]
+        (->> vectors (reduce add-curve content))))))
 
 (defn get-segments
   "Given a content and a set of points return all the segments in the path