Updates selrects, groups to path

This commit is contained in:
alonso.torres 2021-09-17 10:50:35 +02:00
parent 1db2895606
commit 6fd35ae5d9
28 changed files with 327 additions and 239 deletions

View file

@ -10,6 +10,7 @@
[app.common.geom.shapes :as gsh]
[app.common.pages :as cp]
[app.common.pages.changes-builder :as cb]
[app.common.path.shapes-to-path :as stp]
[app.common.uuid :as uuid]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.common :as dwc]
@ -18,24 +19,6 @@
[cuerdas.core :as str]
[potok.core :as ptk]))
(def ^:const style-properties
[:fill-color
:fill-opacity
:fill-color-gradient
:fill-color-ref-file
:fill-color-ref-id
:stroke-color
:stroke-color-ref-file
:stroke-color-ref-id
:stroke-opacity
:stroke-style
:stroke-width
:stroke-alignment
:stroke-cap-start
:stroke-cap-end
:shadow
:blur])
(defn selected-shapes
[state]
(let [objects (wsh/lookup-page-objects state)]
@ -47,10 +30,10 @@
(sort-by ::index))))
(defn create-bool-data
[type name shapes]
(let [head (first shapes)
head-data (select-keys head style-properties)
selrect (gsh/selection-rect shapes)]
[type name shapes objects]
(let [shapes (mapv #(stp/convert-to-path % objects) shapes)
head (first shapes)
head-data (select-keys head stp/style-properties)]
(-> {:id (uuid/next)
:type :bool
:bool-type type
@ -60,7 +43,7 @@
::index (::index head)
:shapes []}
(merge head-data)
(gsh/setup selrect))))
(gsh/update-bool-selrect shapes objects))))
(defn create-bool
[bool-type]
@ -69,14 +52,14 @@
(watch [it state _]
(let [page-id (:current-page-id state)
objects (wsh/lookup-page-objects state page-id)
objects (wsh/lookup-page-objects state)
base-name (-> bool-type d/name str/capital (str "-1"))
name (-> (dwc/retrieve-used-names objects)
(dwc/generate-unique-name base-name))
shapes (selected-shapes state)]
(when-not (empty? shapes)
(let [boolean-data (create-bool-data bool-type name shapes)
(let [boolean-data (create-bool-data bool-type name shapes objects)
shape-id (:id boolean-data)
changes (-> (cb/empty-changes it page-id)
(cb/add-obj boolean-data)

View file

@ -7,7 +7,10 @@
(ns app.main.data.workspace.path.drawing
(:require
[app.common.geom.point :as gpt]
[app.common.geom.shapes.path :as upg]
[app.common.pages :as cp]
[app.common.path.commands :as upc]
[app.common.path.shapes-to-path :as upsp]
[app.common.spec :as us]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.common :as dwc]
@ -21,9 +24,6 @@
[app.main.data.workspace.path.undo :as undo]
[app.main.data.workspace.state-helpers :as wsh]
[app.main.streams :as ms]
[app.util.path.commands :as upc]
[app.util.path.geom :as upg]
[app.util.path.shapes-to-path :as upsp]
[beicon.core :as rx]
[potok.core :as ptk]))

View file

@ -8,6 +8,10 @@
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.path :as upg]
[app.common.path.commands :as upc]
[app.common.path.shapes-to-path :as upsp]
[app.common.path.subpaths :as ups]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.common :as dwc]
[app.main.data.workspace.path.changes :as changes]
@ -19,10 +23,6 @@
[app.main.data.workspace.path.undo :as undo]
[app.main.data.workspace.state-helpers :as wsh]
[app.main.streams :as ms]
[app.util.path.commands :as upc]
[app.util.path.geom :as upg]
[app.util.path.shapes-to-path :as upsp]
[app.util.path.subpaths :as ups]
[app.util.path.tools :as upt]
[beicon.core :as rx]
[potok.core :as ptk]))

View file

@ -10,10 +10,10 @@
[app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]
[app.common.path.commands :as upc]
[app.common.path.subpaths :as ups]
[app.main.data.workspace.path.common :as common]
[app.main.streams :as ms]
[app.util.path.commands :as upc]
[app.util.path.subpaths :as ups]
[potok.core :as ptk]))
(defn end-path-event? [event]

View file

@ -0,0 +1,21 @@
;; 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.path.shapes-to-path
(:require
[app.common.path.shapes-to-path :as upsp]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.state-helpers :as wsh]
[beicon.core :as rx]
[potok.core :as ptk]))
(defn convert-selected-to-path []
(ptk/reify ::convert-selected-to-path
ptk/WatchEvent
(watch [_ state _]
(let [objects (wsh/lookup-page-objects state)
selected (wsh/lookup-selected state)]
(rx/of (dch/update-shapes selected #(upsp/convert-to-path % objects)))))))

View file

@ -7,7 +7,7 @@
(ns app.main.data.workspace.path.state
(:require
[app.common.data :as d]
[app.util.path.shapes-to-path :as upsp]))
[app.common.path.shapes-to-path :as upsp]))
(defn get-path-id
"Retrieves the currently editing path id"
@ -31,7 +31,8 @@
[state & ks]
(let [path-loc (get-path-location state)
shape (-> (get-in state path-loc)
(upsp/convert-to-path))]
;; Empty map because we know the current shape will not have children
(upsp/convert-to-path {}))]
(if (empty? ks)
shape

View file

@ -7,12 +7,12 @@
(ns app.main.data.workspace.path.streams
(:require
[app.common.geom.point :as gpt]
[app.common.geom.shapes.path :as upg]
[app.common.math :as mth]
[app.main.data.workspace.path.state :as state]
[app.main.snap :as snap]
[app.main.store :as st]
[app.main.streams :as ms]
[app.util.path.geom :as upg]
[beicon.core :as rx]
[okulary.core :as l]
[potok.core :as ptk]))

View file

@ -6,13 +6,13 @@
(ns app.main.data.workspace.path.tools
(:require
[app.common.path.shapes-to-path :as upsp]
[app.common.path.subpaths :as ups]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.common :as dwc]
[app.main.data.workspace.path.changes :as changes]
[app.main.data.workspace.path.state :as st]
[app.main.data.workspace.state-helpers :as wsh]
[app.util.path.shapes-to-path :as upsp]
[app.util.path.subpaths :as ups]
[app.util.path.tools :as upt]
[beicon.core :as rx]
[potok.core :as ptk]))

View file

@ -243,16 +243,34 @@
([ids {:keys [with-modifiers?]
:or { with-modifiers? false }}]
(l/derived (fn [state]
(let [objects (wsh/lookup-page-objects state)
modifiers (:workspace-modifiers state)
objects (cond-> objects
with-modifiers?
(gsh/merge-modifiers modifiers))
xform (comp (map #(get objects %))
(remove nil?))]
(into [] xform ids)))
st/state =)))
(let [selector
(fn [state]
(let [objects (wsh/lookup-page-objects state)
modifiers (:workspace-modifiers state)
objects (cond-> objects
with-modifiers?
(gsh/merge-modifiers modifiers))
xform (comp (map #(get objects %))
(remove nil?))]
(into [] xform ids)))]
(l/derived selector st/state =))))
(defn select-children [id]
(let [selector
(fn [state]
(let [objects (wsh/lookup-page-objects state)
children (cp/select-children id objects)
modifiers (-> (:workspace-modifiers state))
{selected :selected disp-modifiers :modifiers}
(-> (:workspace-local state)
(select-keys [:modifiers :selected]))
modifiers (merge modifiers
(into #{} (map #(vector % disp-modifiers)) selected))]
(gsh/merge-modifiers children modifiers)))]
(l/derived selector st/state =)))
(def selected-data
(l/derived #(let [selected (wsh/lookup-selected %)

View file

@ -6,11 +6,10 @@
(ns app.main.ui.shapes.bool
(:require
[app.common.geom.shapes :as gsh]
[app.common.path.bool :as pb]
[app.common.path.shapes-to-path :as stp]
[app.main.ui.hooks :refer [use-equal-memo]]
[app.util.object :as obj]
[app.util.path.bool :as pb]
[app.util.path.shapes-to-path :as stp]
[rumext.alpha :as mf]))
(defn bool-shape
@ -20,32 +19,25 @@
[props]
(let [frame (obj/get props "frame")
shape (obj/get props "shape")
childs (obj/get props "childs")]
childs (obj/get props "childs")
(when (> (count childs) 1)
(let [shape-1 (stp/convert-to-path (nth childs 0))
shape-2 (stp/convert-to-path (nth childs 1))
childs (use-equal-memo childs)
content-1 (use-equal-memo (-> shape-1 gsh/transform-shape :content))
content-2 (use-equal-memo (-> shape-2 gsh/transform-shape :content))
bool-content
(mf/use-memo
(mf/deps childs)
(fn []
(->> shape
:shapes
(map #(get childs %))
(map #(stp/convert-to-path % childs))
(mapv :content)
(pb/content-bool (:bool-type shape)))))]
content
(mf/use-memo
(mf/deps content-1 content-2)
#(pb/content-bool (:bool-type shape) content-1 content-2))]
[:*
[:& shape-wrapper {:shape (-> shape
(assoc :type :path)
(assoc :content content))
:frame frame}]
#_[:g
(for [point (app.util.path.geom/content->points content)]
[:circle {:cx (:x point)
:cy (:y point)
:r 1
:style {:fill "blue"}}])]])))))
[:& shape-wrapper {:shape (-> shape
(assoc :type :path)
(assoc :content bool-content))
:frame frame}])))

View file

@ -10,6 +10,7 @@
[app.main.data.modal :as modal]
[app.main.data.workspace :as dw]
[app.main.data.workspace.libraries :as dwl]
[app.main.data.workspace.path.shapes-to-path :as dwpe]
[app.main.data.workspace.shortcuts :as sc]
[app.main.data.workspace.undo :as dwu]
[app.main.refs :as refs]
@ -147,6 +148,7 @@
do-boolean-difference (st/emitf (dw/create-bool :difference))
do-boolean-intersection (st/emitf (dw/create-bool :intersection))
do-boolean-exclude (st/emitf (dw/create-bool :exclude))
do-transform-to-path (st/emitf (dwpe/convert-selected-to-path))
]
[:*
[:& menu-entry {:title (tr "workspace.shape.menu.copy")
@ -214,6 +216,9 @@
:shortcut (sc/get-tooltip :start-editing)
:on-click do-start-editing}])
[:& menu-entry {:title "Transform to path"
:on-click do-transform-to-path}]
[:& menu-entry {:title (tr "workspace.shape.menu.path")}
[:& menu-entry {:title (tr "workspace.shape.menu.union")
:shortcut (sc/get-tooltip :boolean-union)
@ -230,8 +235,7 @@
[:& menu-separator]
;; TODO
[:& menu-entry {:title "Flatten"}]
[:& menu-entry {:title "Transform to path"}]]
[:& menu-entry {:title "Flatten"}]]
(if (:hidden shape)
[:& menu-entry {:title (tr "workspace.shape.menu.show")

View file

@ -33,17 +33,11 @@
(let [shape (unchecked-get props "shape")
frame (unchecked-get props "frame")
childs-ref (mf/use-memo (mf/deps shape) #(refs/objects-by-id (:shapes shape) {:with-modifiers? true}))
{:keys [selected modifiers]} (mf/deref refs/local-displacement)
childs-ref (mf/use-memo
(mf/deps (:id shape))
#(refs/select-children (:id shape)))
add-modifiers
(fn [{:keys [id] :as shape}]
(cond-> shape
(contains? selected id)
(update :modifiers merge modifiers)))
childs (->> (mf/deref childs-ref)
(mapv add-modifiers))]
childs (mf/deref childs-ref)]
[:> shape-container {:shape shape}
[:& shape-component

View file

@ -6,11 +6,11 @@
(ns app.main.ui.workspace.shapes.path
(:require
[app.common.path.commands :as upc]
[app.main.refs :as refs]
[app.main.ui.shapes.path :as path]
[app.main.ui.shapes.shape :refer [shape-container]]
[app.main.ui.workspace.shapes.path.common :as pc]
[app.util.path.commands :as upc]
[rumext.alpha :as mf]))
(mf/defc path-wrapper

View file

@ -8,7 +8,9 @@
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.path :as gshp]
[app.common.geom.shapes.path :as gsp]
[app.common.path.commands :as upc]
[app.common.path.shapes-to-path :as ups]
[app.main.data.workspace.path :as drp]
[app.main.snap :as snap]
[app.main.store :as st]
@ -18,10 +20,7 @@
[app.main.ui.workspace.shapes.path.common :as pc]
[app.util.dom :as dom]
[app.util.keyboard :as kbd]
[app.util.path.commands :as upc]
[app.util.path.format :as upf]
[app.util.path.geom :as upg]
[app.util.path.shapes-to-path :as ups]
[clojure.set :refer [map-invert]]
[goog.events :as events]
[rumext.alpha :as mf])
@ -217,16 +216,16 @@
shape (cond-> shape
(not= :path (:type shape))
ups/convert-to-path
(ups/convert-to-path {})
:always
hooks/use-equal-memo)
base-content (:content shape)
base-points (mf/use-memo (mf/deps base-content) #(->> base-content upg/content->points))
base-points (mf/use-memo (mf/deps base-content) #(->> base-content gsp/content->points))
content (upc/apply-content-modifiers base-content content-modifiers)
content-points (mf/use-memo (mf/deps content) #(->> content upg/content->points))
content-points (mf/use-memo (mf/deps content) #(->> content gsp/content->points))
point->base (->> (map hash-map content-points base-points) (reduce merge))
base->point (map-invert point->base)
@ -269,7 +268,7 @@
ms/mouse-position
(mf/deps shape zoom)
(fn [position]
(when-let [point (gshp/path-closest-point shape position)]
(when-let [point (gsp/path-closest-point shape position)]
(reset! hover-point (when (< (gpt/distance position point) (/ 10 zoom)) point)))))
[:g.path-editor {:ref editor-ref}

View file

@ -1,220 +0,0 @@
;; 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.util.path.bool
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.path :as gsp]
[app.util.path.commands :as upc]
[app.util.path.geom :as upg]
[app.util.path.subpaths :as ups]))
(defn- split-command
[cmd values]
(case (:command cmd)
:line-to (upg/split-line-to-ranges (:prev cmd) cmd values)
:curve-to (upg/split-curve-to-ranges (:prev cmd) cmd values)
[cmd]))
(defn split [seg-1 seg-2]
(let [[ts-seg-1 ts-seg-2]
(cond
(and (= :line-to (:command seg-1))
(= :line-to (:command seg-2)))
(gsp/line-line-intersect (gsp/command->line seg-1) (gsp/command->line seg-2))
(and (= :line-to (:command seg-1))
(= :curve-to (:command seg-2)))
(gsp/line-curve-intersect (gsp/command->line seg-1) (gsp/command->bezier seg-2))
(and (= :curve-to (:command seg-1))
(= :line-to (:command seg-2)))
(let [[seg-2' seg-1']
(gsp/line-curve-intersect (gsp/command->line seg-2) (gsp/command->bezier seg-1))]
;; Need to reverse because we send the arguments reversed
[seg-1' seg-2'])
(and (= :curve-to (:command seg-1))
(= :curve-to (:command seg-2)))
(gsp/curve-curve-intersect (gsp/command->bezier seg-1) (gsp/command->bezier seg-2))
:else
[[] []])]
[(split-command seg-1 ts-seg-1)
(split-command seg-2 ts-seg-2)]))
(defn add-previous
([content]
(add-previous content nil))
([content first]
(->> (d/with-prev content)
(mapv (fn [[cmd prev]]
(cond-> cmd
(and (nil? prev) (some? first))
(assoc :prev first)
(some? prev)
(assoc :prev (gsp/command->point prev))))))))
(defn content-intersect-split
"Given two path contents will return the intersect between them"
[content-a content-b]
(if (or (empty? content-a) (empty? content-b))
[content-a content-b]
(loop [current (first content-a)
pending (rest content-a)
content-b content-b
new-content-a []]
(if (not (some? current))
[new-content-a content-b]
(let [[new-current new-pending new-content-b]
(loop [current current
pending pending
other (first content-b)
head-content []
tail-content (rest content-b)]
(if (not (some? other))
;; Finished recorring second content
[current pending head-content]
;; We split the current
(let [[new-as new-bs] (split current other)
new-as (add-previous new-as (:prev current))
new-bs (add-previous new-bs (:prev other))]
(if (> (count new-as) 1)
;; We add the new-a's to the stack and change the b then we iterate to the top
(recur (first new-as)
(d/concat [] (rest new-as) pending)
(first tail-content)
(d/concat [] head-content new-bs)
(rest tail-content))
;; No current segment-segment split we continue searching
(recur current
pending
(first tail-content)
(conj head-content other)
(rest tail-content))))))]
(recur (first new-pending)
(rest new-pending)
new-content-b
(conj new-content-a new-current)))))))
(defn is-segment?
[cmd]
(and (contains? cmd :prev)
(contains? #{:line-to :curve-to} (:command cmd))))
(defn contains-segment?
[segment content]
(let [point (case (:command segment)
:line-to (-> (gsp/command->line segment)
(gsp/line-values 0.5))
:curve-to (-> (gsp/command->bezier segment)
(gsp/curve-values 0.5)))]
(gsp/is-point-in-content? point content)))
(defn create-union [content-a content-a-split content-b content-b-split]
;; Pick all segments in content-a that are not inside content-b
;; Pick all segments in content-b that are not inside content-a
(d/concat
[]
(->> content-a-split (filter #(not (contains-segment? % content-b))))
(->> content-b-split (filter #(not (contains-segment? % content-a))))))
(defn create-difference [content-a content-a-split content-b content-b-split]
;; Pick all segments in content-a that are not inside content-b
;; Pick all segments in content b that are inside content-a
(d/concat
[]
(->> content-a-split (filter #(not (contains-segment? % content-b))))
(->> content-b-split (filter #(contains-segment? % content-a)))))
(defn create-intersection [content-a content-a-split content-b content-b-split]
;; Pick all segments in content-a that are inside content-b
;; Pick all segments in content-b that are inside content-a
(d/concat
[]
(->> content-a-split (filter #(contains-segment? % content-b)))
(->> content-b-split (filter #(contains-segment? % content-a)))))
(defn reverse-command
"Reverses a single command"
[command]
(let [{old-x :x old-y :y} (:params command)
{:keys [x y]} (:prev command)
{:keys [c1x c1y c2x c2y]} (:params command)]
(-> command
(assoc :prev (gpt/point old-x old-y))
(update :params assoc :x x :y y)
(cond-> (= :curve-to (:command command))
(update :params assoc
:c1x c2x :c1y c2y
:c2x c1x :c2y c1y)))))
(defn create-exclusion [content-a content-b]
;; Pick all segments but reverse content-b (so it makes an exclusion)
(let [content-b' (->> (reverse content-b)
(mapv reverse-command))]
(d/concat [] content-a content-b')))
(defn fix-move-to
[content]
;; Remove the field `:prev` and makes the necesaries `move-to`
;; then clean the subpaths
(loop [current (first content)
content (rest content)
prev nil
result []]
(if (nil? current)
result
(let [result (if (not= (:prev current) prev)
(conj result (upc/make-move-to (:prev current)))
result)]
(recur (first content)
(rest content)
(gsp/command->point current)
(conj result (dissoc current :prev)))))))
(defn content-bool
[bool-type content-a content-b]
(let [content-a (add-previous content-a)
content-b (add-previous 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-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)
:difference (create-difference content-a content-a-split content-b content-b-split)
:intersection (create-intersection content-a content-a-split content-b content-b-split)
:exclude (create-exclusion content-a-split content-b-split))]
(->> (fix-move-to bool-content)
(ups/close-subpaths))))

View file

@ -1,202 +0,0 @@
;; 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.util.path.commands
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]))
(defn command->point
([prev-pos {:keys [relative params] :as command}]
(let [{:keys [x y] :or {x (:x prev-pos) y (:y prev-pos)}} params]
(if relative
(-> prev-pos (update :x + x) (update :y + y))
(command->point command))))
([command]
(when-not (nil? command)
(let [{{:keys [x y]} :params} command]
(gpt/point x y)))))
(defn make-move-to [to]
{:command :move-to
:relative false
:params {:x (:x to)
:y (:y to)}})
(defn make-line-to [to]
{:command :line-to
:relative false
:params {:x (:x to)
:y (:y to)}})
(defn make-curve-params
([point]
(make-curve-params point point point))
([point handler] (make-curve-params point handler point))
([point h1 h2]
{:x (:x point)
:y (:y point)
:c1x (:x h1)
:c1y (:y h1)
:c2x (:x h2)
:c2y (:y 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 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 :command])))
(-> (assoc-in [index :command] :curve-to)
(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))
(:c1x params) (update-in [index :params :c1x] + (:c1x params))
(:c1y params) (update-in [index :params :c1y] + (:c1y params))
(:c2x params) (update-in [index :params :c2x] + (:c2x params))
(:c2y params) (update-in [index :params :c2y] + (:c2y params)))
content))]
(let [content (if (vector? content) content (into [] content))]
(reduce apply-to-index content modifiers))))
(defn get-handler [{:keys [params] :as command} prefix]
(let [cx (d/prefix-keyword prefix :x)
cy (d/prefix-keyword prefix :y)]
(when (and command
(contains? params cx)
(contains? params cy))
(gpt/point (get params cx)
(get params cy)))))
(defn content->handlers
"Retrieve a map where for every point will retrieve a list of
the handlers that are associated with that point.
point -> [[index, prefix]]"
[content]
(->> (d/with-prev content)
(d/enumerate)
(mapcat (fn [[index [cur-cmd pre-cmd]]]
(if (and pre-cmd (= :curve-to (:command cur-cmd)))
(let [cur-pos (command->point cur-cmd)
pre-pos (command->point pre-cmd)]
(-> [[pre-pos [index :c1]]
[cur-pos [index :c2]]]))
[])))
(group-by first)
(d/mapm #(mapv second %2))))
(defn point-indices
[content point]
(->> (d/enumerate content)
(filter (fn [[_ cmd]] (= point (command->point cmd))))
(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)
(mapcat (fn [[index [cur-cmd pre-cmd]]]
(if (and (some? pre-cmd) (= :curve-to (:command cur-cmd)))
(let [cur-pos (command->point cur-cmd)
pre-pos (command->point pre-cmd)]
(cond-> []
(= pre-pos point) (conj [index :c1])
(= cur-pos point) (conj [index :c2])))
[])))))
(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))))
point->handlers (content->handlers content)
handlers (->> point
(point->handlers )
(filter (fn [[ci cp]] (and (not= index ci) (not= prefix cp)) )))]
(cond
(= (count handlers) 1)
(->> handlers first)
(and (= :c1 prefix) (= (count content) index))
[(dec index) :c2]
:else nil)))
(defn get-commands
"Returns the commands involving a point with its indices"
[content point]
(->> (d/enumerate content)
(filterv (fn [[_ cmd]] (= (command->point cmd) point)))))
(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] (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)
(command->point (get content (dec index)))
(command->point (get content index))))

View file

@ -6,8 +6,8 @@
(ns app.util.path.format
(:require
[app.util.path.commands :as upc]
[app.util.path.subpaths :refer [pt=]]
[app.common.path.commands :as upc]
[app.common.path.subpaths :refer [pt=]]
[cuerdas.core :as str]))
(defn command->param-list [command]

View file

@ -1,97 +0,0 @@
;; 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.util.path.geom
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.path :as gshp]
[app.util.path.commands :as upc]))
(defn calculate-opposite-handler
"Given a point and its handler, gives the symetric handler"
[point handler]
(let [handler-vector (gpt/to-vec point handler)]
(gpt/add point (gpt/negate handler-vector))))
(defn split-line-to
"Given a point and a line-to command will create a two new line-to commands
that will split the original line into two given a value between 0-1"
[from-p cmd t-val]
(let [to-p (upc/command->point cmd)
sp (gpt/lerp from-p to-p t-val)]
[(upc/make-line-to sp) cmd]))
(defn split-curve-to
"Given the point and a curve-to command will split the curve into two new
curve-to commands given a value between 0-1"
[from-p cmd t-val]
(let [params (:params cmd)
end (gpt/point (:x params) (:y params))
h1 (gpt/point (:c1x params) (:c1y params))
h2 (gpt/point (:c2x params) (:c2y params))
[[_ to1 h11 h21]
[_ to2 h12 h22]] (gshp/curve-split from-p end h1 h2 t-val)]
[(upc/make-curve-to to1 h11 h21)
(upc/make-curve-to to2 h12 h22)]))
(defn split-line-to-ranges
"Splits a line into several lines given the points in `values`
for example (split-line-to-ranges p c [0 0.25 0.5 0.75 1] will split
the line into 4 lines"
[from-p cmd values]
(let [to-p (upc/command->point cmd)]
(->> (conj values 1)
(mapv (fn [val]
(-> (gpt/lerp from-p to-p val)
#_(gpt/round 2)
(upc/make-line-to)))))))
(defn split-curve-to-ranges
"Splits a curve into several curves given the points in `values`
for example (split-curve-to-ranges p c [0 0.25 0.5 0.75 1] will split
the curve into 4 curves that draw the same curve"
[from-p cmd values]
(if (empty? values)
[cmd]
(let [to-p (upc/command->point cmd)
params (:params cmd)
h1 (gpt/point (:c1x params) (:c1y params))
h2 (gpt/point (:c2x params) (:c2y params))
values-set (->> (conj values 1) (into (sorted-set)))]
(->> (d/with-prev values-set)
(mapv
(fn [[t1 t0]]
(let [t0 (if (nil? t0) 0 t0)
[_ to-p h1' h2'] (gshp/subcurve-range from-p to-p h1 h2 t0 t1)]
(upc/make-curve-to (-> to-p #_(gpt/round 2)) h1' h2'))))))))
(defn opposite-handler
"Calculates the coordinates of the opposite handler"
[point handler]
(let [phv (gpt/to-vec point handler)]
(gpt/add point (gpt/negate phv))))
(defn opposite-handler-keep-distance
"Calculates the coordinates of the opposite handler but keeping the old distance"
[point handler old-opposite]
(let [old-distance (gpt/distance point old-opposite)
phv (gpt/to-vec point handler)
phv2 (gpt/multiply
(gpt/unit (gpt/negate phv))
(gpt/point old-distance))]
(gpt/add point phv2)))
(defn content->points
"Returns the points in the given content"
[content]
(->> content
(map #(when (-> % :params :x)
(gpt/point (-> % :params :x) (-> % :params :y))))
(remove nil?)
(into [])))

View file

@ -8,9 +8,9 @@
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.path :as upg]
[app.common.path.commands :as upc]
[app.util.path.arc-to-curve :refer [a2c]]
[app.util.path.commands :as upc]
[app.util.path.geom :as upg]
[app.util.svg :as usvg]
[cuerdas.core :as str]))

View file

@ -1,146 +0,0 @@
;; 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.util.path.shapes-to-path
(:require
[app.common.data :as d]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh]
[app.common.geom.shapes.path :as gsp]
[app.util.path.commands :as pc]))
(def bezier-circle-c 0.551915024494)
(def dissoc-attrs [:x :y :width :height
:rx :ry :r1 :r2 :r3 :r4
:medata])
(def allowed-transform-types #{:rect
:circle
:image})
(defn make-corner-arc
"Creates a curvle corner for border radius"
[from to corner radius]
(let [x (case corner
:top-left (:x from)
:top-right (- (:x from) radius)
:bottom-right (- (:x to) radius)
:bottom-left (:x to))
y (case corner
:top-left (- (:y from) radius)
:top-right (:y from)
:bottom-right (- (:y to) (* 2 radius))
:bottom-left (- (:y to) radius))
width (* radius 2)
height (* radius 2)
c bezier-circle-c
c1x (+ x (* (/ width 2) (- 1 c)))
c2x (+ x (* (/ width 2) (+ 1 c)))
c1y (+ y (* (/ height 2) (- 1 c)))
c2y (+ y (* (/ height 2) (+ 1 c)))
h1 (case corner
:top-left (assoc from :y c1y)
:top-right (assoc from :x c2x)
:bottom-right (assoc from :y c2y)
:bottom-left (assoc from :x c1x))
h2 (case corner
:top-left (assoc to :x c1x)
:top-right (assoc to :y c1y)
:bottom-right (assoc to :x c2x)
:bottom-left (assoc to :y c2y))]
(pc/make-curve-to to h1 h2)))
(defn circle->path
"Creates the bezier curves to approximate a circle shape"
[x y width height]
(let [mx (+ x (/ width 2))
my (+ y (/ height 2))
ex (+ x width)
ey (+ y height)
p1 (gpt/point mx y)
p2 (gpt/point ex my)
p3 (gpt/point mx ey)
p4 (gpt/point x my)
c bezier-circle-c
c1x (+ x (* (/ width 2) (- 1 c)))
c2x (+ x (* (/ width 2) (+ 1 c)))
c1y (+ y (* (/ height 2) (- 1 c)))
c2y (+ y (* (/ height 2) (+ 1 c)))]
[(pc/make-move-to p1)
(pc/make-curve-to p2 (assoc p1 :x c2x) (assoc p2 :y c1y))
(pc/make-curve-to p3 (assoc p2 :y c2y) (assoc p3 :x c2x))
(pc/make-curve-to p4 (assoc p3 :x c1x) (assoc p4 :y c2y))
(pc/make-curve-to p1 (assoc p4 :y c1y) (assoc p1 :x c1x))]))
(defn rect->path
"Creates a bezier curve that approximates a rounded corner rectangle"
[x y width height r1 r2 r3 r4]
(let [p1 (gpt/point x (+ y r1))
p2 (gpt/point (+ x r1) y)
p3 (gpt/point (+ width x (- r2)) y)
p4 (gpt/point (+ width x) (+ y r2))
p5 (gpt/point (+ width x) (+ height y (- r3)))
p6 (gpt/point (+ width x (- r3)) (+ height y))
p7 (gpt/point (+ x r4) (+ height y))
p8 (gpt/point x (+ height y (- r4)))]
(-> []
(conj (pc/make-move-to p1))
(cond-> (not= p1 p2)
(conj (make-corner-arc p1 p2 :top-left r1)))
(conj (pc/make-line-to p3))
(cond-> (not= p3 p4)
(conj (make-corner-arc p3 p4 :top-right r2)))
(conj (pc/make-line-to p5))
(cond-> (not= p5 p6)
(conj (make-corner-arc p5 p6 :bottom-right r3)))
(conj (pc/make-line-to p7))
(cond-> (not= p7 p8)
(conj (make-corner-arc p7 p8 :bottom-left r4)))
(conj (pc/make-line-to p1)))))
(defn convert-to-path
"Transforms the given shape to a path"
[{:keys [type x y width height r1 r2 r3 r4 rx metadata] :as shape}]
(if (contains? allowed-transform-types type)
(let [r1 (or r1 rx 0)
r2 (or r2 rx 0)
r3 (or r3 rx 0)
r4 (or r4 rx 0)
new-content
(case type
:circle
(circle->path x y width height)
(rect->path x y width height r1 r2 r3 r4))
;; Apply the transforms that had the shape
transform (:transform shape)
new-content (cond-> new-content
(some? transform)
(gsp/transform-content (gmt/transform-in (gsh/center-shape shape) transform)))]
(-> shape
(d/without-keys dissoc-attrs)
(assoc :type :path)
(assoc :content new-content)
(cond-> (= :image type) (-> (assoc :fill-image metadata)
(dissoc :metadata)))))
;; Do nothing if the shape is not of a correct type
shape))

View file

@ -1,160 +0,0 @@
;; 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.util.path.subpaths
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.util.path.commands :as upc]))
(defn pt=
"Check if two points are close"
[p1 p2]
(< (gpt/distance p1 p2) 0.1))
(defn make-subpath
"Creates a subpath either from a single command or with all the data"
([command]
(let [p (upc/command->point command)]
(make-subpath p p [command])))
([from to data]
{:from from
:to to
:data data}))
(defn add-subpath-command
"Adds a command to the subpath"
[subpath command]
(let [command (if (= :close-path (:command command))
(upc/make-line-to (:from subpath))
command)
p (upc/command->point command)]
(-> subpath
(assoc :to p)
(update :data conj command))))
(defn reverse-command
"Reverses a single command"
[command prev]
(let [{:keys [x y]} (:params prev)
{:keys [c1x c1y c2x c2y]} (:params command)]
(-> command
(update :params assoc :x x :y y)
(cond-> (= :curve-to (:command command))
(update :params assoc
:c1x c2x :c1y c2y
:c2x c1x :c2y c1y)))))
(defn reverse-subpath
"Reverses a subpath starting with move-to"
[subpath]
(let [reverse-commands
(fn [result [command prev]]
(if (some? prev)
(conj result (reverse-command command prev))
result))
new-data (->> subpath :data d/with-prev reverse
(reduce reverse-commands [(upc/make-move-to (:to subpath))]))]
(make-subpath (:to subpath) (:from subpath) new-data)))
(defn get-subpaths
"Retrieves every subpath inside the current content"
[content]
(let [reduce-subpath
(fn [subpaths current]
(let [is-move? (= :move-to (:command current))
last-idx (dec (count subpaths))]
(if is-move?
(conj subpaths (make-subpath current))
(update subpaths last-idx add-subpath-command current))))]
(->> content
(reduce reduce-subpath []))))
(defn subpaths-join
"Join two subpaths together when the first finish where the second starts"
[subpath other]
(assert (pt= (:to subpath) (:from other)))
(-> subpath
(update :data d/concat (rest (:data other)))
(assoc :to (:to other))))
(defn- merge-paths
"Tries to merge into candidate the subpaths. Will return the candidate with the subpaths merged
and removed from subpaths the subpaths merged"
[candidate subpaths]
(let [merge-with-candidate
(fn [[candidate result] current]
(cond
(pt= (:to current) (:from current))
;; Subpath is already a closed path
[candidate (conj result current)]
(pt= (:to candidate) (:from current))
[(subpaths-join candidate current) result]
(pt= (:from candidate) (:to current))
[(subpaths-join current candidate) result]
(pt= (:to candidate) (:to current))
[(subpaths-join candidate (reverse-subpath current)) result]
(pt= (:from candidate) (:from current))
[(subpaths-join (reverse-subpath current) candidate) result]
:else
[candidate (conj result current)]))]
(->> subpaths
(reduce merge-with-candidate [candidate []]))))
(defn close-subpaths
"Searches a path for posible supaths that can create closed loops and merge them"
[content]
(let [subpaths (get-subpaths content)
closed-subpaths
(loop [result []
current (first subpaths)
subpaths (rest subpaths)]
(if (some? current)
(let [[new-current new-subpaths]
(if (pt= (:from current) (:to current))
[current subpaths]
(merge-paths current subpaths))]
(if (= current new-current)
;; If equal we haven't found any matching subpaths we advance
(recur (conj result new-current)
(first new-subpaths)
(rest new-subpaths))
;; If different we need to pass again the merge to check for additional
;; subpaths to join
(recur result
new-current
new-subpaths)))
result))]
(->> closed-subpaths
(mapcat :data)
(into []))))
(defn reverse-content
"Given a content reverse the order of the commands"
[content]
(->> content
(get-subpaths)
(mapv reverse-subpath)
(reverse)
(mapcat :data)
(into [])))

View file

@ -8,9 +8,9 @@
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.path :as upg]
[app.common.math :as mth]
[app.util.path.commands :as upc]
[app.util.path.geom :as upg]
[app.common.path.commands :as upc]
[clojure.set :as set]))
(defn remove-line-curves