From 33bcbd89f13129419e8d21106863a3665acb325d Mon Sep 17 00:00:00 2001 From: Andrey Antukh Date: Tue, 8 Apr 2025 22:01:58 +0200 Subject: [PATCH] :zap: Optimize calculate-extremities path helper Heavily used on path edition --- common/src/app/common/types/path/helpers.cljc | 210 ++++++++++++------ common/src/app/common/types/path/segment.cljc | 86 ++++--- .../common_tests/types/path_data_test.cljc | 77 +++++++ 3 files changed, 277 insertions(+), 96 deletions(-) diff --git a/common/src/app/common/types/path/helpers.cljc b/common/src/app/common/types/path/helpers.cljc index bba145faeb..a02ce8a7fa 100644 --- a/common/src/app/common/types/path/helpers.cljc +++ b/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] - (solve-roots a b c 0)) - - ([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]))))))) + ([a b c] (solve-roots a b c 0)) + ([a b c d] (solve-roots* [] conj a b c d))) ;; 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] diff --git a/common/src/app/common/types/path/segment.cljc b/common/src/app/common/types/path/segment.cljc index d648d372a3..22c8183d18 100644 --- a/common/src/app/common/types/path/segment.cljc +++ b/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 - (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)) - + (let [extremities (calculate-extremities content) ;; We haven't found any extremes so we turn the commands to points extremities (if (empty? extremities) diff --git a/common/test/common_tests/types/path_data_test.cljc b/common/test/common_tests/types/path_data_test.cljc index 3df0156dea..8effd1a46b 100644 --- a/common/test/common_tests/types/path_data_test.cljc +++ b/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))))