⚡ Improves boolean performance

common/src/app/common/geom/shapes.cljc

@@ -184,3 +184,4 @@
 
 ;; Bool
 (d/export gsb/update-bool-selrect)
+(d/export gsb/calc-bool-content)

common/src/app/common/geom/shapes/bool.cljc

@@ -6,21 +6,27 @@
 
 (ns app.common.geom.shapes.bool
   (:require
+   [app.common.data :as d]
    [app.common.geom.shapes.path :as gsp]
    [app.common.geom.shapes.rect :as gpr]
    [app.common.geom.shapes.transforms :as gtr]
    [app.common.path.bool :as pb]
    [app.common.path.shapes-to-path :as stp]))
 
+(defn calc-bool-content
+  [shape objects]
+  (->> (:shapes shape)
+       (map (d/getf objects))
+       (filter (comp not :hidden))
+       (map #(stp/convert-to-path % objects))
+       (mapv :content)
+       (pb/content-bool (:bool-type shape))))
+
 (defn update-bool-selrect
   "Calculates the selrect+points for the boolean shape"
   [shape children objects]
 
-  (let [content (->> children
+  (let [content (calc-bool-content shape objects)
-                     (map #(stp/convert-to-path % objects))
-                     (mapv :content)
-                     (pb/content-bool (:bool-type shape)))
-
         [points selrect]
         (if (empty? content)
           (let [selrect (gtr/selection-rect children)
@@ -29,4 +35,6 @@
           (gsp/content->points+selrect shape content))]
     (-> shape
         (assoc :selrect selrect)
-        (assoc :points points))))
+        (assoc :points points)
+        (assoc :bool-content content))))
+

common/src/app/common/geom/shapes/path.cljc

@@ -279,11 +279,18 @@
           (filterv #(and (>= % 0) (<= % 1)))))))
 
 (defn command->point
-  ([command] (command->point command nil))
+  ([command]
-  ([{params :params} coord]
+   (command->point command nil))
-   (let [prefix (if coord (name coord) "")
+
-         xkey (keyword (str prefix "x"))
+  ([command coord]
-         ykey (keyword (str prefix "y"))
+   (let [params (:params command)
+         xkey (cond (= :c1 coord) :c1x
+                    (= :c2 coord) :c2x
+                    :else         :x)
+         ykey (cond (= :c1 coord) :c1y
+                    (= :c2 coord) :c2y
+                    :else         :y)
+
          x (get params xkey)
          y (get params ykey)]
      (when (and (some? x) (some? y))
@@ -322,7 +329,7 @@
                                                (command->point command :c1)
                                                (command->point command :c2)]]
                                     (->> (curve-extremities curve)
-                                         (map #(curve-values curve %)))))
+                                         (mapv #(curve-values curve %)))))
                   [])
          selrect (gpr/points->selrect points)]
      (-> selrect
@@ -676,8 +683,6 @@
 
     (curve-roots c2' :y)))
 
-
-
 (defn ray-line-intersect
   [point [a b :as line]]
 
@@ -708,20 +713,19 @@
       [[l1-t] [l2-t]])))
 
 (defn ray-curve-intersect
-  [ray-line c2]
+  [ray-line curve]
 
-  (let [;; ray-line [point (gpt/point (inc (:x point)) (:y point))]
+  (let [curve-ts (->> (line-curve-crossing ray-line curve)
-        curve-ts (->> (line-curve-crossing ray-line c2)
+                      (filterv #(let [curve-v (curve-values curve %)
-                      (filterv #(let [curve-v (curve-values c2 %)
+                                      curve-tg (curve-tangent curve %)
-                                      curve-tg (curve-tangent c2 %)
                                       curve-tg-angle (gpt/angle curve-tg)
                                       ray-t (get-line-tval ray-line curve-v)]
                                   (and (> ray-t 0)
                                        (> (mth/abs (- curve-tg-angle 180)) 0.01)
                                        (> (mth/abs (- curve-tg-angle 0)) 0.01)) )))]
     (->> curve-ts
-         (mapv #(vector (curve-values c2 %)
+         (mapv #(vector (curve-values curve %)
-                        (curve-windup c2 %))))))
+                        (curve-windup curve %))))))
 
 (defn line-curve-intersect
   [l1 c2]
@@ -817,32 +821,58 @@
     (->> content
          (some inside-border?))))
 
-(defn is-point-in-content?
+(defn close-content
-  [point content]
+  [content]
-  (let [selrect (content->selrect content)
+  (into []
-        ray-line [point (gpt/point (inc (:x point)) (:y point))]
+        (comp  (filter sp/is-closed?)
+               (mapcat :data))
+        (->> content
+             (sp/close-subpaths)
+             (sp/get-subpaths))))
 
-        closed-content
+
-        (into []
+(defn ray-overlaps?
-              (comp  (filter sp/is-closed?)
+  [ray-point {selrect :selrect}]
-                     (mapcat :data))
+  (and (>= (:y ray-point) (:y1 selrect))
-              (->> content
+       (<= (:y ray-point) (:y2 selrect))))
-                   (sp/close-subpaths)
+
-                   (sp/get-subpaths)))
+(defn content->geom-data
+  [content]
+
+  (->> content
+       (close-content)
+       (filter #(not= (= :line-to (:command %))
+                      (= :curve-to (:command %))))
+       (mapv (fn [segment]
+               {:command (:command segment)
+                :segment segment
+                :geom (if (= :line-to (:command segment))
+                        (command->line segment)
+                        (command->bezier segment))
+                :selrect (command->selrect segment)}))))
+
+(defn is-point-in-geom-data?
+  [point content-geom]
+
+  (let [ray-line [point (gpt/point (inc (:x point)) (:y point))]
 
         cast-ray
-        (fn [cmd]
+        (fn [data]
-          (case (:command cmd)
+          (case (:command data)
-            :line-to  (ray-line-intersect  point (command->line cmd))
+            :line-to
-            :curve-to (ray-curve-intersect ray-line (command->bezier cmd))
+            (ray-line-intersect point (:geom data))
-            #_:else   []))]
 
-    (and (gpr/contains-point? selrect point)
+            :curve-to
-         (->> closed-content
+            (ray-curve-intersect ray-line (:geom data))
-              (mapcat cast-ray)
+
-              (map second)
+            #_:default []))]
-              (reduce +)
+
-              (not= 0)))))
+    (->> content-geom
+         (filter (partial ray-overlaps? point))
+         (mapcat cast-ray)
+         (map second)
+         (reduce +)
+         (not= 0))))
 
 (defn split-line-to
   "Given a point and a line-to command will create a two new line-to commands

common/src/app/common/path/bool.cljc

@@ -91,55 +91,55 @@
     :else
     [[] []]))
 
-(defn split
-  [seg-1 seg-2]
-  (let [r1 (gsp/command->selrect seg-1)
-        r2 (gsp/command->selrect seg-2)]
-    (if (not (gpr/overlaps-rects? r1 r2))
-      [[seg-1] [seg-2]]
-      (let [[ts-seg-1 ts-seg-2] (split-ts seg-1 seg-2)]
-        [(-> (split-command seg-1 ts-seg-1) (add-previous (:prev seg-1)))
-         (-> (split-command seg-2 ts-seg-2) (add-previous (:prev seg-2)))]))))
-
 (defn content-intersect-split
-  [content-a content-b]
+  [content-a content-b sr-a sr-b]
 
-  (let [cache (atom {})]
+  (let [command->selrect (memoize gsp/command->selrect)]
-    (letfn [(split-cache [seg-1 seg-2]
-              (cond
-                (contains? @cache [seg-1 seg-2])
-                (first (get @cache [seg-1 seg-2]))
 
-                (contains? @cache [seg-2 seg-1])
+    (letfn [(overlap-segment-selrect?
-                (second (get @cache [seg-2 seg-1]))
+              [segment selrect]
+              (if (= :move-to (:command segment))
+                false
+                (let [r1 (command->selrect segment)]
+                  (gpr/overlaps-rects? r1 selrect))))
 
-                :else
+            (overlap-segments?
-                (let [value (split seg-1 seg-2)]
+              [seg-1 seg-2]
-                  (swap! cache assoc [seg-1 seg-2] value)
+              (if (or (= :move-to (:command seg-1))
-                  (first value))))
+                      (= :move-to (:command seg-2)))
+                false
+                (let [r1 (command->selrect seg-1)
+                      r2 (command->selrect seg-2)]
+                  (gpr/overlaps-rects? r1 r2))))
+
+            (split
+              [seg-1 seg-2]
+              (if (not (overlap-segments? seg-1 seg-2))
+                [seg-1]
+                (let [[ts-seg-1 _] (split-ts seg-1 seg-2)]
+                  (-> (split-command seg-1 ts-seg-1)
+                      (add-previous (:prev seg-1))))))
 
             (split-segment-on-content
-              [segment content]
+              [segment content content-sr]
 
-              (loop [current (first content)
+              (if (overlap-segment-selrect? segment content-sr)
-                     content (rest content)
+                (->> content
-                     result [segment]]
+                     (filter #(overlap-segments? segment %))
-
+                     (reduce
-                (if (nil? current)
+                      (fn [result current]
-                  result
+                        (into [] (mapcat #(split % current)) result))
-                  (let [result (->> result (into [] (mapcat #(split-cache % current))))]
+                      [segment]))
-                    (recur (first content)
+                [segment]))
-                           (rest content)
-                           result)))))
 
             (split-content
-              [content-a content-b]
+              [content-a content-b sr-b]
               (into []
-                    (mapcat #(split-segment-on-content % content-b))
+                    (mapcat #(split-segment-on-content % content-b sr-b))
                     content-a))]
 
-      [(split-content content-a content-b)
+      [(split-content content-a content-b sr-b)
-       (split-content content-b content-a)])))
+       (split-content content-b content-a sr-a)])))
 
 (defn is-segment?
   [cmd]
@@ -147,7 +147,7 @@
        (contains? #{:line-to :curve-to} (:command cmd))))
 
 (defn contains-segment?
-  [segment content]
+  [segment content content-sr content-geom]
 
   (let [point (case (:command segment)
                 :line-to  (-> (gsp/command->line segment)
@@ -156,11 +156,13 @@
                 :curve-to (-> (gsp/command->bezier segment)
                               (gsp/curve-values 0.5)))]
 
-    (or (gsp/is-point-in-content? point content)
+    (and (gpr/contains-point? content-sr point)
-        (gsp/is-point-in-border? point content))))
+         (or
+          (gsp/is-point-in-geom-data? point content-geom)
+          (gsp/is-point-in-border? point content)))))
 
 (defn inside-segment?
-  [segment content]
+  [segment content-sr content-geom]
   (let [point (case (:command segment)
                 :line-to  (-> (gsp/command->line segment)
                               (gsp/line-values 0.5))
@@ -168,7 +170,8 @@
                 :curve-to (-> (gsp/command->bezier segment)
                               (gsp/curve-values 0.5)))]
 
-    (gsp/is-point-in-content? point content)))
+    (and (gpr/contains-point? content-sr point)
+         (gsp/is-point-in-geom-data? point content-geom))))
 
 (defn overlap-segment?
   "Finds if the current segment is overlapping against other
@@ -209,49 +212,59 @@
          (d/seek overlap-single?)
          (some?))))
 
-(defn create-union [content-a content-a-split content-b content-b-split]
+(defn create-union [content-a content-a-split content-b content-b-split sr-a sr-b]
   ;; Pick all segments in content-a that are not inside content-b
   ;; Pick all segments in content-b that are not inside content-a
-  (let [content
+  (let [content-a-geom (gsp/content->geom-data content-a)
+        content-b-geom (gsp/content->geom-data content-b)
+
+        content
         (concat
-         (->> content-a-split (filter #(not (contains-segment? % content-b))))
+         (->> content-a-split (filter #(not (contains-segment? % content-b sr-b content-b-geom))))
-         (->> content-b-split (filter #(not (contains-segment? % content-a)))))
+         (->> content-b-split (filter #(not (contains-segment? % content-a sr-a content-a-geom)))))
+
+        content-geom (gsp/content->geom-data content)
+
+        content-sr (gsp/content->selrect content)
 
         ;; Overlapping segments should be added when they are part of the border
         border-content
         (->> content-b-split
-             (filter #(and (contains-segment? % content-a)
+             (filter #(and (contains-segment? % content-a sr-a content-a-geom)
                            (overlap-segment? % content-a-split)
-                           (not (inside-segment? % content)))))]
+                           (not (inside-segment? % content-sr content-geom)))))]
 
     ;; Ensure that the output is always a vector
     (d/concat-vec content border-content)))
 
-(defn create-difference [content-a content-a-split content-b content-b-split]
+(defn create-difference [content-a content-a-split content-b content-b-split sr-a sr-b]
   ;; Pick all segments in content-a that are not inside content-b
   ;; Pick all segments in content b that are inside content-a
   ;;  removing overlapping
-  (d/concat-vec
+  (let [content-a-geom (gsp/content->geom-data content-a)
-   (->> content-a-split (filter #(not (contains-segment? % content-b))))
+        content-b-geom (gsp/content->geom-data content-b)]
+    (d/concat-vec
+     (->> content-a-split (filter #(not (contains-segment? % content-b sr-b content-b-geom))))
 
-   ;; Reverse second content so we can have holes inside other shapes
+     ;; Reverse second content so we can have holes inside other shapes
-   (->> content-b-split
+     (->> content-b-split
-        (filter #(and (contains-segment? % content-a)
+          (filter #(and (contains-segment? % content-a sr-a content-a-geom)
-                      (not (overlap-segment? % content-a-split)))))))
+                        (not (overlap-segment? % content-a-split))))))))
 
-(defn create-intersection [content-a content-a-split content-b content-b-split]
+(defn create-intersection [content-a content-a-split content-b content-b-split sr-a sr-b]
   ;; Pick all segments in content-a that are inside content-b
   ;; Pick all segments in content-b that are inside content-a
-  (d/concat-vec
+  (let [content-a-geom (gsp/content->geom-data content-a)
-   (->> content-a-split (filter #(contains-segment? % content-b)))
+        content-b-geom (gsp/content->geom-data content-b)]
-   (->> content-b-split (filter #(contains-segment? % content-a)))))
+    (d/concat-vec
+     (->> content-a-split (filter #(contains-segment? % content-b sr-b content-b-geom)))
+     (->> content-b-split (filter #(contains-segment? % content-a sr-a content-a-geom))))))
 
 
 (defn create-exclusion [content-a content-b]
   ;; Pick all segments
   (d/concat-vec content-a content-b))
 
-
 (defn fix-move-to
   [content]
   ;; Remove the field `:prev` and makes the necessaries `move-to`
@@ -284,16 +297,19 @@
                         (ups/reverse-content))
                       (add-previous))
 
+        sr-a (gsp/content->selrect content-a)
+        sr-b (gsp/content->selrect content-b)
+
         ;; Split content in new segments in the intersection with the other path
-        [content-a-split content-b-split] (content-intersect-split content-a content-b)
+        [content-a-split content-b-split] (content-intersect-split content-a content-b sr-a sr-b)
         content-a-split (->> content-a-split add-previous (filter is-segment?))
         content-b-split (->> content-b-split add-previous (filter is-segment?))
 
         bool-content
         (case bool-type
-          :union        (create-union        content-a content-a-split content-b content-b-split)
+          :union        (create-union        content-a content-a-split content-b content-b-split sr-a sr-b)
-          :difference   (create-difference   content-a content-a-split content-b content-b-split)
+          :difference   (create-difference   content-a content-a-split content-b content-b-split sr-a sr-b)
-          :intersection (create-intersection content-a content-a-split content-b content-b-split)
+          :intersection (create-intersection content-a content-a-split content-b content-b-split sr-a sr-b)
           :exclude      (create-exclusion    content-a-split content-b-split))]
 
     (->> (fix-move-to bool-content)

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

@@ -28,6 +28,7 @@
    [app.main.data.workspace.changes :as dch]
    [app.main.data.workspace.common :as dwc]
    [app.main.data.workspace.drawing :as dwd]
+   [app.main.data.workspace.fix-bool-contents :as fbc]
    [app.main.data.workspace.groups :as dwg]
    [app.main.data.workspace.interactions :as dwi]
    [app.main.data.workspace.libraries :as dwl]
@@ -213,8 +214,11 @@
                                       (or (not ignore-until)
                                           (> (:modified-at %) ignore-until)))
                                 libraries)]
-        (when needs-update?
+        (rx/merge
-          (rx/of (dwl/notify-sync-file file-id)))))))
+         (rx/of (fbc/fix-bool-contents))
+         (if needs-update?
+           (rx/of (dwl/notify-sync-file file-id))
+           (rx/empty)))))))
 
 (defn finalize-file
   [_project-id file-id]
@@ -307,7 +311,7 @@
   [page-id]
   (ptk/reify ::duplicate-page
     ptk/WatchEvent
-    (watch [this state _]
+    (watch [it state _]
       (let [id      (uuid/next)
             pages   (get-in state [:workspace-data :pages-index])
             unames  (dwc/retrieve-used-names pages)
@@ -322,7 +326,7 @@
                      :id id}]
         (rx/of (dch/commit-changes {:redo-changes [rchange]
                                     :undo-changes [uchange]
-                                    :origin this}))))))
+                                    :origin it}))))))
 
 (s/def ::rename-page
   (s/keys :req-un [::id ::name]))

frontend/src/app/main/data/workspace/fix_bool_contents.cljs

@@ -0,0 +1,94 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.main.data.workspace.fix-bool-contents
+  (:require
+   [app.common.data :as d]
+   [app.common.geom.shapes :as gsh]
+   [app.main.data.workspace.changes :as dch]
+   [app.main.data.workspace.state-helpers :as wsh]
+   [beicon.core :as rx]
+   [potok.core :as ptk]))
+
+;; This event will update the file so the boolean data has a pre-generated path data
+;; to increase performance.
+;; For new shapes this will be generated in the :reg-objects but we need to do this for
+;; old files.
+
+;; FIXME: Remove me after June 2022
+
+(defn fix-bool-contents
+  "This event will calculate the bool content and update the page. This is kind of a 'addhoc' migration
+  to fill the optional value 'bool-content'"
+  []
+
+  (letfn [(should-migrate-shape? [shape]
+            (and (= :bool (:type shape)) (not (contains? shape :bool-content))))
+
+          (should-migrate-component? [component]
+            (->> (:objects component)
+                 (vals)
+                 (d/seek should-migrate-shape?)))
+
+          (update-shape [shape objects]
+            (cond-> shape
+              (should-migrate-shape? shape)
+              (assoc :bool-content (gsh/calc-bool-content shape objects))))
+
+          (migrate-component [component]
+            (-> component
+                (update
+                 :objects
+                 (fn [objects]
+                   (d/mapm #(update-shape %2 objects) objects)))))
+
+          (update-library
+            [library]
+            (-> library
+                (d/update-in-when
+                 [:data :components]
+                 (fn [components]
+                   (d/mapm #(migrate-component %2) components)))))]
+
+    (ptk/reify ::fix-bool-contents
+      ptk/UpdateEvent
+      (update [_ state]
+        ;; Update (only-local) the imported libraries
+        (-> state
+            (d/update-when
+             :workspace-libraries
+             (fn [libraries] (d/mapm #(update-library %2) libraries)))))
+
+      ptk/WatchEvent
+      (watch [it state _]
+        (let [objects (wsh/lookup-page-objects state)
+
+              ids (into #{}
+                        (comp (filter should-migrate-shape?) (map :id))
+                        (vals objects))
+
+              components (->> (wsh/lookup-local-components state)
+                              (vals)
+                              (filter should-migrate-component?))
+
+              component-changes
+              (into []
+                    (map (fn [component]
+                           {:type :mod-component
+                            :id (:id component)
+                            :objects (-> component migrate-component :objects)}))
+                    components)]
+
+          (rx/of (dch/update-shapes ids #(update-shape % objects) {:reg-objects? false
+                                                                   :save-undo? false
+                                                                   :ignore-tree true}))
+
+          (if (empty? component-changes)
+            (rx/empty)
+            (rx/of (dch/commit-changes {:origin it
+                                        :redo-changes component-changes
+                                        :undo-changes []
+                                        :save-undo? false}))))))))

frontend/src/app/main/data/workspace/state_helpers.cljs

@@ -25,6 +25,10 @@
   ([state component-id]
    (get-in state [:workspace-data :components component-id :objects])))
 
+(defn lookup-local-components
+  ([state]
+   (get-in state [:workspace-data :components])))
+
 (defn lookup-selected
   ([state]
    (lookup-selected state nil))

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

@@ -6,8 +6,7 @@
 
 (ns app.main.ui.shapes.bool
   (:require
-   [app.common.path.bool :as pb]
+   [app.common.geom.shapes :as gsh]
-   [app.common.path.shapes-to-path :as stp]
    [app.main.ui.hooks :refer [use-equal-memo]]
    [app.main.ui.shapes.export :as use]
    [app.main.ui.shapes.path :refer [path-shape]]
@@ -27,13 +26,8 @@
                 bool-content
                 (mf/use-memo
                  (mf/deps shape childs)
-                 (fn []
+                 #(or (:bool-content shape)
-                   (->> (:shapes shape)
+                      (gsh/calc-bool-content shape childs)))]
-                        (map #(get childs %))
-                        (filter #(not (:hidden %)))
-                        (map #(stp/convert-to-path % childs))
-                        (mapv :content)
-                        (pb/content-bool (:bool-type shape)))))]
 
             [:*
              [:& path-shape {:shape (assoc shape :content bool-content)}]