⚡ Optimize calculate-extremities path helper

Heavily used on path edition

common/src/app/common/types/path/helpers.cljc

@@ -13,6 +13,7 @@
   namespaces without incurrying on circular depedency cycles."
   (:require
    [app.common.data :as d]
+   [app.common.data.macros :as dm]
    [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
    [app.common.geom.rect :as grc]
@@ -114,6 +115,18 @@
      (when (and (some? x) (some? y))
        (gpt/point x y)))))
 
+(defn segment->point
+  ([segment] (segment->point segment :x))
+  ([segment coord]
+   (let [params (get segment :params)]
+     (case coord
+       :c1 (gpt/point (get params :c1x)
+                      (get params :c1y))
+       :c2 (gpt/point (get params :c2x)
+                      (get params :c2y))
+       (gpt/point (get params :x)
+                  (get params :y))))))
+
 (defn command->line
   ([cmd]
    (command->line cmd (:prev cmd)))
@@ -199,73 +212,94 @@
 
      (gpt/point (coord-v :x) (coord-v :y)))))
 
+(defn solve-roots*
+  "Solvers a quadratic or cubic equation given by the parameters a b c d.
+
+  Implemented as reduction algorithm (this helps implemement
+  derivative algorithms that does not require intermediate results
+  thanks to transducers."
+  [result conj a b c d]
+  (let [sqrt-b2-4ac (mth/sqrt (- (* b b) (* 4 a c)))]
+    (cond
+      ;; No solutions
+      (and ^boolean (mth/almost-zero? d)
+           ^boolean (mth/almost-zero? a)
+           ^boolean (mth/almost-zero? b))
+      result
+
+      ;; Linear solution
+      (and ^boolean (mth/almost-zero? d)
+           ^boolean (mth/almost-zero? a))
+      (conj result (/ (- c) b))
+
+      ;; Quadratic
+      ^boolean
+      (mth/almost-zero? d)
+      (-> result
+          (conj (/ (+ (- b) sqrt-b2-4ac)
+                   (* 2 a)))
+          (conj (/ (- (- b) sqrt-b2-4ac)
+                   (* 2 a))))
+
+      ;; Cubic
+      :else
+      (let [a (/ a d)
+            b (/ b d)
+            c (/ c d)
+
+            p (/ (- (* 3 b) (* a a)) 3)
+            q (/ (+ (* 2 a a a) (* -9 a b) (* 27 c)) 27)
+
+            p3 (/ p 3)
+            q2 (/ q 2)
+            discriminant (+ (* q2 q2) (* p3 p3 p3))]
+
+        (cond
+          (< discriminant 0)
+          (let [mp3 (/ (- p) 3)
+                mp33 (* mp3 mp3 mp3)
+                r (mth/sqrt mp33)
+                t (/ (- q) (* 2 r))
+                cosphi (cond (< t -1) -1
+                             (> t 1) 1
+                             :else t)
+                phi (mth/acos cosphi)
+                crtr (mth/cubicroot r)
+                t1 (* 2 crtr)
+                root1 (- (* t1 (mth/cos (/ phi 3))) (/ a 3))
+                root2 (- (* t1 (mth/cos (/ (+ phi (* 2 mth/PI)) 3))) (/ a 3))
+                root3 (- (* t1 (mth/cos (/ (+ phi (* 4 mth/PI)) 3))) (/ a 3))]
+
+            (-> result
+                (conj root1)
+                (conj root2)
+                (conj root3)))
+
+          ^boolean
+          (mth/almost-zero? discriminant)
+          (let [u1 (if (< q2 0) (mth/cubicroot (- q2)) (- (mth/cubicroot q2)))
+                root1 (- (* 2 u1) (/ a 3))
+                root2 (- (- u1) (/ a 3))]
+            (-> result
+                (conj root1)
+                (conj root2)))
+
+          :else
+          (let [sd (mth/sqrt discriminant)
+                u1 (mth/cubicroot (- sd q2))
+                v1 (mth/cubicroot (+ sd q2))
+                root (- u1 v1 (/ a 3))]
+            (conj result root)))))))
+
+
+
+
+
 ;; https://trans4mind.com/personal_development/mathematics/polynomials/cubicAlgebra.htm
 (defn- solve-roots
   "Solvers a quadratic or cubic equation given by the parameters a b c d"
-  ([a b c]
+  ([a b c] (solve-roots a b c 0))
-   (solve-roots a b c 0))
+  ([a b c d] (solve-roots* [] conj a b c d)))
-
-  ([a b c d]
-   (let [sqrt-b2-4ac (mth/sqrt (- (* b b) (* 4 a c)))]
-     (cond
-       ;; No solutions
-       (and (mth/almost-zero? d) (mth/almost-zero? a) (mth/almost-zero? b))
-       []
-
-       ;; Linear solution
-       (and (mth/almost-zero? d) (mth/almost-zero? a))
-       [(/ (- c) b)]
-
-       ;; Quadratic
-       (mth/almost-zero? d)
-       [(/ (+ (- b) sqrt-b2-4ac)
-           (* 2 a))
-        (/ (- (- b) sqrt-b2-4ac)
-           (* 2 a))]
-
-       ;; Cubic
-       :else
-       (let [a (/ a d)
-             b (/ b d)
-             c (/ c d)
-
-             p  (/ (- (* 3 b) (* a a)) 3)
-             q (/ (+ (* 2 a a a) (* -9 a b) (* 27 c)) 27)
-
-             p3 (/ p 3)
-             q2 (/ q 2)
-             discriminant (+ (* q2 q2) (* p3 p3 p3))]
-
-         (cond
-           (< discriminant 0)
-           (let [mp3 (/ (- p) 3)
-                 mp33 (* mp3 mp3 mp3)
-                 r (mth/sqrt mp33)
-                 t (/ (- q) (* 2 r))
-                 cosphi (cond (< t -1) -1
-                              (> t 1) 1
-                              :else t)
-                 phi (mth/acos cosphi)
-                 crtr (mth/cubicroot r)
-                 t1 (* 2 crtr)
-                 root1 (- (* t1 (mth/cos (/ phi 3))) (/ a 3))
-                 root2 (- (* t1 (mth/cos (/ (+ phi (* 2 mth/PI)) 3))) (/ a 3))
-                 root3 (- (* t1 (mth/cos (/ (+ phi (* 4 mth/PI)) 3))) (/ a 3))]
-
-             [root1 root2 root3])
-
-           (mth/almost-zero? discriminant)
-           (let [u1 (if (< q2 0) (mth/cubicroot (- q2)) (- (mth/cubicroot q2)))
-                 root1 (- (* 2 u1) (/ a 3))
-                 root2 (- (- u1) (/ a 3))]
-             [root1 root2])
-
-           :else
-           (let [sd (mth/sqrt discriminant)
-                 u1 (mth/cubicroot (- sd q2))
-                 v1 (mth/cubicroot (+ sd q2))
-                 root (- u1 v1 (/ a 3))]
-             [root])))))))
 
 ;; https://pomax.github.io/bezierinfo/#extremities
 (defn curve-extremities
@@ -292,6 +326,54 @@
           ;; Only values in the range [0, 1] are valid
           (filterv #(and (> % 0.01) (< % 0.99)))))))
 
+(defn calculate-curve-extremities
+  "Calculates the extremities by solving the first derivative for a
+  cubic bezier and then solving the quadratic formula"
+  [start end h1 h2]
+  (let [start-x (dm/get-prop start :x)
+        h1-x    (dm/get-prop h1 :x)
+        h2-x    (dm/get-prop h2 :x)
+        end-x   (dm/get-prop end :x)
+        start-y (dm/get-prop start :y)
+        h1-y    (dm/get-prop h1 :y)
+        h2-y    (dm/get-prop h2 :y)
+        end-y   (dm/get-prop end :y)
+
+        xform
+        (comp
+         (filter #(and (> % 0.01) (< % 0.99)))
+         (map (fn [t]
+                (let [t2      (* t t)  ;; t square
+                      t3      (* t2 t) ;; t cube
+                      start-v (+ (- t3) (* 3 t2) (* -3 t) 1)
+                      h1-v    (+ (* 3 t3) (* -6 t2) (* 3 t))
+                      h2-v    (+ (* -3 t3) (* 3 t2))
+                      end-v   t3]
+                  (gpt/point
+                   (+ (* start-x start-v)
+                      (* h1-x    h1-v)
+                      (* h2-x    h2-v)
+                      (* end-x   end-v))
+                   (+ (* start-y start-v)
+                      (* h1-y    h1-v)
+                      (* h2-y    h2-v)
+                      (* end-y   end-v)))))))
+
+        conj*
+        (xform conj!)
+
+        process-curve
+        (fn [result c0 c1 c2 c3]
+          (let [a (+ (* -3 c0) (*   9 c1) (* -9 c2) (* 3 c3))
+                b (+ (*  6 c0) (* -12 c1) (* 6 c2))
+                c (+ (*  3 c1) (*  -3 c0))]
+            (solve-roots* result conj* a b c 0)))]
+
+    (-> (transient [])
+        (process-curve start-x h1-x h2-x end-x)
+        (process-curve start-y h1-y h2-y end-y)
+        (persistent!))))
+
 (defn curve-tangent
   "Retrieve the tangent vector to the curve in the point `t`"
   [[start end h1 h2] t]

common/src/app/common/types/path/segment.cljc

@@ -838,40 +838,62 @@
   (let [transform (gmt/translate-matrix move-vec)]
     (transform-content content transform)))
 
-;; FIXME: add optimizations
+(defn calculate-extremities
+  "Calculate extremities for the provided content"
+  [content]
+  (loop [points  (transient #{})
+         content (not-empty (vec content))
+         from-p  nil
+         move-p  nil]
+    (if content
+      (let [last-p  (peek content)
+            content (if (= :move-to (:command last-p))
+                      (pop content)
+                      content)
+            segment (get content 0)
+            to-p    (helpers/segment->point segment)]
+
+        (if segment
+          (case (:command segment)
+            :move-to
+            (recur (conj! points to-p)
+                   (not-empty (subvec content 1))
+                   to-p
+                   to-p)
+
+            :close-path
+            (recur (conj! points move-p)
+                   (not-empty (subvec content 1))
+                   move-p
+                   move-p)
+
+            :line-to
+            (recur (cond-> points
+                     (and from-p to-p)
+                     (-> (conj! move-p)
+                         (conj! to-p)))
+                   (not-empty (subvec content 1))
+                   to-p
+                   move-p)
+
+            :curve-to
+            (let [c1 (helpers/segment->point segment :c1)
+                  c2 (helpers/segment->point segment :c2)]
+              (recur (if (and from-p to-p c1 c2)
+                       (reduce conj!
+                               (-> points (conj! from-p) (conj! to-p))
+                               (helpers/calculate-curve-extremities from-p to-p c1 c2))
+                       points)
+
+                     (not-empty (subvec content 1))
+                     to-p
+                     move-p)))
+          (persistent! points)))
+      (persistent! points))))
+
 (defn content->selrect
   [content]
-  (let [extremities
+  (let [extremities (calculate-extremities content)
-        (loop [points #{}
-               from-p nil
-               move-p nil
-               content (seq content)]
-          (if content
-            (let [last-p (last content)
-                  content (if (= :move-to (:command last-p))
-                            (butlast content)
-                            content)
-                  command (first content)
-                  to-p    (helpers/command->point command)
-
-                  [from-p move-p command-pts]
-                  (case (:command command)
-                    :move-to    [to-p   to-p   (when to-p [to-p])]
-                    :close-path [move-p move-p (when move-p [move-p])]
-                    :line-to    [to-p   move-p (when (and from-p to-p) [from-p to-p])]
-                    :curve-to   [to-p   move-p
-                                 (let [c1 (helpers/command->point command :c1)
-                                       c2 (helpers/command->point command :c2)
-                                       curve [from-p to-p c1 c2]]
-                                   (when (and from-p to-p c1 c2)
-                                     (into [from-p to-p]
-                                           (->> (helpers/curve-extremities curve)
-                                                (map #(helpers/curve-values curve %))))))]
-                    [to-p move-p []])]
-
-              (recur (apply conj points command-pts) from-p move-p (next content)))
-            points))
-
         ;; We haven't found any extremes so we turn the commands to points
         extremities
         (if (empty? extremities)

common/test/common_tests/types/path_data_test.cljc

@@ -14,6 +14,8 @@
    [app.common.pprint :as pp]
    [app.common.transit :as trans]
    [app.common.types.path :as path]
+   [app.common.types.path.helpers :as path.helpers]
+   [app.common.types.path.impl :as path.impl]
    [app.common.types.path.segment :as path.segment]
    [clojure.test :as t]))
 
@@ -199,3 +201,78 @@
 
     (t/is (= result1 result2))
     (t/is (= result2 result3))))
+
+(defn calculate-extremities
+  "Calculate extremities for the provided content.
+  A legacy implementation used mainly as reference for testing"
+  [content]
+  (loop [points #{}
+         from-p nil
+         move-p nil
+         content (seq content)]
+    (if content
+      (let [last-p (last content)
+            content (if (= :move-to (:command last-p))
+                      (butlast content)
+                      content)
+            command (first content)
+            to-p    (path.helpers/command->point command)
+
+            [from-p move-p command-pts]
+            (case (:command command)
+              :move-to    [to-p   to-p   (when to-p [to-p])]
+              :close-path [move-p move-p (when move-p [move-p])]
+              :line-to    [to-p   move-p (when (and from-p to-p) [from-p to-p])]
+              :curve-to   [to-p   move-p
+                           (let [c1 (path.helpers/command->point command :c1)
+                                 c2 (path.helpers/command->point command :c2)
+                                 curve [from-p to-p c1 c2]]
+                             (when (and from-p to-p c1 c2)
+                               (into [from-p to-p]
+                                     (->> (path.helpers/curve-extremities curve)
+                                          (map #(path.helpers/curve-values curve %))))))]
+              [to-p move-p []])]
+
+        (recur (apply conj points command-pts) from-p move-p (next content)))
+      points)))
+
+(t/deftest extremities-1
+  (let [pdata   (path/content sample-content)
+        result1 (calculate-extremities sample-content)
+        result2 (calculate-extremities pdata)
+        result3 (path.segment/calculate-extremities sample-content)
+        result4 (path.segment/calculate-extremities pdata)
+        expect  #{(gpt/point 480.0 839.0)
+                  (gpt/point 439.0 802.0)
+                  (gpt/point 264.0 634.0)}
+        n-iter  100000]
+
+    (t/is (= result1 result3))
+    (t/is (= result1 expect))
+    (t/is (= result2 expect))
+    (t/is (= result3 expect))
+    (t/is (= result4 expect))))
+
+(def sample-content-2
+  [{:command :move-to, :params {:x 480.0, :y 839.0}}
+   {:command :line-to, :params {:x 439.0, :y 802.0}}
+   {:command :curve-to, :params {:c1x 368.0, :c1y 737.0, :c2x 310.0, :c2y 681.0, :x 4.0, :y 4.0}}
+   {:command :curve-to, :params {:c1x 3.0, :c1y 7.0, :c2x 30.0, :c2y -68.0, :x 20.0, :y 20.0}}
+   {:command :close-path :params {}}])
+
+(t/deftest extremities-2
+  (let [result1 (path.segment/calculate-extremities sample-content-2)
+        result2 (calculate-extremities sample-content-2)]
+    (t/is (= result1 result2))))
+
+(t/deftest extremities-3
+  (let [segments [{:command :move-to, :params {:x -310.5355224609375, :y 452.62115478515625}}]
+        content  (path/content segments)
+        result1  (calculate-extremities segments)
+        result2  (path.segment/calculate-extremities segments)
+        result3  (path.segment/calculate-extremities content)
+        expect   #{}]
+    (t/is (= result1 expect))
+    (t/is (= result1 expect))
+    (t/is (= result2 expect))
+    (t/is (= result3 expect))))