Add minor improvements to curve drawing internal impl

This commit is contained in:
Andrey Antukh 2025-04-10 12:11:12 +02:00
parent 6f2ccabaa2
commit 1abaff9c52
4 changed files with 85 additions and 64 deletions

View file

@ -7,12 +7,11 @@
(ns app.main.data.workspace.drawing.curve
(:require
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes.flex-layout :as gslf]
[app.common.geom.shapes.grid-layout :as gslg]
[app.common.types.container :as ctn]
[app.common.types.path.segment :as path.segm]
[app.common.types.path.segment :as path.segment]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
[app.common.types.shape.layout :as ctl]
@ -25,7 +24,37 @@
[beicon.v2.core :as rx]
[potok.v2.core :as ptk]))
(def simplify-tolerance 0.3)
(def ^:const simplify-tolerance 0.3)
(defn- setup-frame
[]
(ptk/reify ::setup-frame
ptk/UpdateEvent
(update [_ state]
(let [objects (dsh/lookup-page-objects state)
content (dm/get-in state [:workspace-drawing :object :content])
position (path.segment/get-handler-point content 0 nil)
frame-id (->> (ctst/top-nested-frame objects position)
(ctn/get-first-not-copy-parent objects) ;; We don't want to change the structure of component copies
:id)
flex-layout? (ctl/flex-layout? objects frame-id)
grid-layout? (ctl/grid-layout? objects frame-id)
drop-index (when flex-layout? (gslf/get-drop-index frame-id objects position))
drop-cell (when grid-layout? (gslg/get-drop-cell frame-id objects position))]
(update-in state [:workspace-drawing :object]
(fn [object]
(-> object
(assoc :frame-id frame-id)
(assoc :parent-id frame-id)
;; FIXME: with-meta twice only one wins
(cond-> (some? drop-index)
(with-meta {:index drop-index}))
(cond-> (some? drop-cell)
(with-meta {:cell drop-cell})))))))))
(defn- insert-point
[point]
@ -34,43 +63,16 @@
(update [_ state]
(update-in state [:workspace-drawing :object]
(fn [object]
(let [segments (-> (:segments object)
(conj point))
content (path.segm/segments->content segments)
selrect (path.segm/content->selrect content)
points (grc/rect->points selrect)]
(let [points (-> (::points object)
(conj point))
content (path.segment/points->content points)
selrect (path.segment/content->selrect content)
points' (grc/rect->points selrect)]
(-> object
(assoc :segments segments)
(assoc ::points points)
(assoc :content content)
(assoc :selrect selrect)
(assoc :points points))))))))
(defn- setup-frame
[]
(ptk/reify ::setup-frame
ptk/UpdateEvent
(update [_ state]
(let [objects (dsh/lookup-page-objects state)
content (dm/get-in state [:workspace-drawing :object :content] [])
start (dm/get-in content [0 :params] nil)
position (when start (gpt/point start))
frame-id (->> (ctst/top-nested-frame objects position)
(ctn/get-first-not-copy-parent objects) ;; We don't want to change the structure of component copies
:id)
flex-layout? (ctl/flex-layout? objects frame-id)
grid-layout? (ctl/grid-layout? objects frame-id)
drop-index (when flex-layout? (gslf/get-drop-index frame-id objects position))
drop-cell (when grid-layout? (gslg/get-drop-cell frame-id objects position))]
(update-in state [:workspace-drawing :object]
(fn [object]
(-> object
(assoc :frame-id frame-id)
(assoc :parent-id frame-id)
(cond-> (some? drop-index)
(with-meta {:index drop-index}))
(cond-> (some? drop-cell)
(with-meta {:cell drop-cell})))))))))
(assoc :points points'))))))))
(defn finish-drawing
[]
@ -78,13 +80,14 @@
ptk/UpdateEvent
(update [_ state]
(update-in state [:workspace-drawing :object]
(fn [{:keys [segments] :as shape}]
(let [segments (ups/simplify segments simplify-tolerance)
content (path.segm/segments->content segments)
selrect (path.segm/content->selrect content)
(fn [{:keys [::points] :as shape}]
(let [points (ups/simplify points simplify-tolerance)
content (path.segment/points->content points)
selrect (path.segment/content->selrect content)
points (grc/rect->points selrect)]
(-> shape
(dissoc :segments)
(dissoc ::points)
(assoc :content content)
(assoc :selrect selrect)
(assoc :points points)
@ -104,7 +107,7 @@
:initialized? true
:frame-id uuid/zero
:parent-id uuid/zero
:segments []})]
::points []})]
(rx/concat
(rx/of #(update % :workspace-drawing assoc :object shape))
(->> mouse