github/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2026-04-27 20:28:11 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #3322 from penpot/niwinz-performance-custom-rect

Browse Source 
⚡ Performance enhancements (part 1)
This commit is contained in:
Alejandro 2023-07-12 07:20:43 +02:00 committed by GitHub
commit 9713f2859f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
171 changed files with 7989 additions and 7117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.circleci/config.yml
View File

@ -34,7 +34,7 @@ jobs:
working_directory: "./frontend"
command: |
yarn install
yarn run lint-scss
yarn run lint:scss
- run:
name: common lint

1
.clj-kondo/config.edn
View File

@ -17,6 +17,7 @@
{app.common.data.macros/export hooks.export/export
potok.core/reify hooks.export/potok-reify
app.util.services/defmethod hooks.export/service-defmethod
app.common.record/defrecord hooks.export/penpot-defrecord
}}
:output

24
.clj-kondo/hooks/export.clj
View File

@ -39,6 +39,29 @@
other))]
{:node result})))
(defn penpot-defrecord
[{:keys [:node]}]
(let [[rnode rtype rparams & other] (:children node)
nodes [(api/token-node (symbol "do"))
(api/list-node
(into [(api/token-node (symbol (name (:value rnode)))) rtype rparams] other))
(api/list-node
[(api/token-node (symbol "defn"))
(api/token-node (symbol (str "pos->" (:string-value rtype))))
(api/vector-node
(->> (:children rparams)
(mapv (fn [t]
(api/token-node (symbol (str "_" (:string-value t))))))))
(api/token-node nil)])]
result (api/list-node nodes)]
;; (prn "=====>" (into {} rparams))
;; (prn (api/sexpr result))
{:node result}))
(defn clojure-specify
[{:keys [:node]}]
(let [[rnode rtype & other] (:children node)
@ -48,7 +71,6 @@
other))]
{:node result}))
(defn service-defmethod
[{:keys [:node]}]
(let [[rnode rtype ?meta & other] (:children node)

2
backend/src/app/rpc/commands/binfile.clj
View File

@ -11,9 +11,9 @@
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.files.features :as ffeat]
[app.common.files.migrations :as pmg]
[app.common.fressian :as fres]
[app.common.logging :as l]
[app.common.pages.migrations :as pmg]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cf]

62
backend/src/app/rpc/commands/files.clj
View File

@ -9,8 +9,8 @@
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.files.migrations :as pmg]
[app.common.pages.helpers :as cph]
[app.common.pages.migrations :as pmg]
[app.common.schema :as sm]
[app.common.schema.desc-js-like :as-alias smdj]
[app.common.schema.generators :as sg]
@ -46,11 +46,14 @@
(def supported-features
#{"storage/objects-map"
"storage/pointer-map"
"internal/shape-record"
"internal/geom-record"
"components/v2"})
(defn get-default-features
[]
(cond-> #{}
(cond-> #{"internal/shape-record"
"internal/geom-record"}
(contains? cf/flags :fdata-storage-pointer-map)
(conj "storage/pointer-map")
@ -305,17 +308,17 @@
;; --- COMMAND QUERY: get-file (by id)
(sm/def! ::features
(def schema:features
[:schema
{:title "FileFeatures"
::smdj/inline true
:gen/gen (sg/subseq supported-features)}
::sm/set-of-strings])
(sm/def! ::file
(def schema:file
[:map {:title "File"}
[:id ::sm/uuid]
[:features ::features]
[:features schema:features]
[:has-media-trimmed :boolean]
[:comment-thread-seqn {:min 0} :int]
[:name :string]
@ -326,18 +329,18 @@
[:created-at ::dt/instant]
[:data {:optional true} :any]])
(sm/def! ::permissions-mixin
(def schema:permissions-mixin
[:map {:title "PermissionsMixin"}
[:permissions ::perms/permissions]])
(sm/def! ::file-with-permissions
(def schema:file-with-permissions
[:merge {:title "FileWithPermissions"}
::file
::permissions-mixin])
schema:file
schema:permissions-mixin])
(sm/def! ::get-file
(def schema:get-file
[:map {:title "get-file"}
[:features {:optional true} ::features]
[:features {:optional true} schema:features]
[:id ::sm/uuid]
[:project-id {:optional true} ::sm/uuid]])
@ -377,8 +380,8 @@
{::doc/added "1.17"
::cond/get-object #(get-minimal-file %1 (:id %2))
::cond/key-fn get-file-etag
::sm/params ::get-file
::sm/result ::file-with-permissions}
::sm/params schema:get-file
::sm/result schema:file-with-permissions}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id id features project-id] :as params}]
(dm/with-open [conn (db/open pool)]
(let [perms (get-permissions conn profile-id id)]
@ -390,14 +393,14 @@
;; --- COMMAND QUERY: get-file-fragment (by id)
(sm/def! ::file-fragment
(def schema:file-fragment
[:map {:title "FileFragment"}
[:id ::sm/uuid]
[:file-id ::sm/uuid]
[:created-at ::dt/instant]
[:content any?]])
(sm/def! ::get-file-fragment
(def schema:get-file-fragment
[:map {:title "get-file-fragment"}
[:file-id ::sm/uuid]
[:fragment-id ::sm/uuid]
@ -411,8 +414,8 @@
(sv/defmethod ::get-file-fragment
"Retrieve a file by its ID. Only authenticated users."
{::doc/added "1.17"
::sm/params ::get-file-fragment
::sm/result ::file-fragment}
::sm/params schema:get-file-fragment
::sm/result schema:file-fragment}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id fragment-id share-id] }]
(dm/with-open [conn (db/open pool)]
(let [perms (get-permissions conn profile-id file-id share-id)]
@ -447,12 +450,18 @@
(assoc :thumbnail-uri (resolve-public-uri media-id)))
(dissoc row :media-id))))))
(def schema:get-project-files
[:map {:title "get-project-files"}
[:project-id ::sm/uuid]])
(def schema:files
[:vector schema:file])
(sv/defmethod ::get-project-files
"Get all files for the specified project."
{::doc/added "1.17"
::sm/params [:map {:title "get-project-files"}
[:project-id ::sm/uuid]]
::sm/result [:vector ::file]}
::sm/params schema:get-project-files
::sm/result schema:files}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id project-id]}]
(dm/with-open [conn (db/open pool)]
(projects/check-read-permissions! conn profile-id project-id)
@ -463,11 +472,14 @@
(declare get-has-file-libraries)
(def schema:has-file-libraries
[:map {:title "has-file-libraries"}
[:file-id ::sm/uuid]])
(sv/defmethod ::has-file-libraries
"Checks if the file has libraries. Returns a boolean"
{::doc/added "1.15.1"
::sm/params [:map {:title "has-file-libraries"}
[:file-id ::sm/uuid]]
::sm/params schema:has-file-libraries
::sm/result :boolean}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id]}]
(dm/with-open [conn (db/open pool)]
@ -522,13 +534,13 @@
(uuid? object-id)
(prune-objects object-id))))
(sm/def! ::get-page
(def schema:get-page
[:map {:title "GetPage"}
[:file-id ::sm/uuid]
[:page-id {:optional true} ::sm/uuid]
[:share-id {:optional true} ::sm/uuid]
[:object-id {:optional true} ::sm/uuid]
[:features {:optional true} ::features]])
[:features {:optional true} schema:features]])
(sv/defmethod ::get-page
"Retrieves the page data from file and returns it. If no page-id is
@ -541,7 +553,7 @@
Mainly used for rendering purposes."
{::doc/added "1.17"
::sm/params ::get-page}
::sm/params schema:get-page}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id share-id] :as params}]
(dm/with-open [conn (db/open pool)]
(let [perms (get-permissions conn profile-id file-id share-id)]

31
backend/src/app/rpc/commands/files_thumbnails.clj
View File

@ -162,18 +162,18 @@
frames (filter cph/frame-shape? (vals objects))]
(if-let [frame (-> frames first)]
(let [frame-id (:id frame)
(let [frame-id (:id frame)
object-id (str page-id frame-id)
frame (if-let [thumb (get thumbnails object-id)]
(assoc frame :thumbnail thumb :shapes [])
(dissoc frame :thumbnail))
frame (if-let [thumb (get thumbnails object-id)]
(assoc frame :thumbnail thumb :shapes [])
(dissoc frame :thumbnail))
children-ids
(cph/get-children-ids objects frame-id)
bounds
(when (:show-content frame)
(gsh/selection-rect (concat [frame] (->> children-ids (map (d/getf objects))))))
(gsh/shapes->rect (cons frame (map (d/getf objects) children-ids))))
frame
(cond-> frame
@ -215,18 +215,25 @@
:always
(update :objects assoc-thumbnails page-id thumbs))))))
(def ^:private schema:get-file-data-for-thumbnail
[:map {:title "get-file-data-for-thumbnail"}
[:file-id ::sm/uuid]
[:features {:optional true} files/schema:features]])
(def ^:private schema:partial-file
[:map {:title "PartialFile"}
[:id ::sm/uuid]
[:revn {:min 0} :int]
[:page :any]])
(sv/defmethod ::get-file-data-for-thumbnail
"Retrieves the data for generate the thumbnail of the file. Used
mainly for render thumbnails on dashboard."
{::doc/added "1.17"
::sm/params [:map {:title "get-file-data-for-thumbnail"}
[:file-id ::sm/uuid]
[:features {:optional true} ::files/features]]
::sm/result [:map {:title "PartialFile"}
[:id ::sm/uuid]
[:revn {:min 0} :int]
[:page :any]]}
::sm/params schema:get-file-data-for-thumbnail
::sm/result schema:partial-file}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id features] :as props}]
(dm/with-open [conn (db/open pool)]
(files/check-read-permissions! conn profile-id file-id)

36
backend/src/app/rpc/commands/files_update.clj
View File

@ -8,13 +8,12 @@
(:require
[app.common.exceptions :as ex]
[app.common.files.features :as ffeat]
[app.common.files.migrations :as pmg]
[app.common.logging :as l]
[app.common.pages :as cp]
[app.common.pages.changes :as cpc]
[app.common.pages.migrations :as pmg]
[app.common.schema :as sm]
[app.common.schema.generators :as smg]
[app.common.spec :as us]
[app.common.types.file :as ctf]
[app.common.uuid :as uuid]
[app.config :as cf]
@ -32,37 +31,7 @@
[app.util.objects-map :as omap]
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[app.util.time :as dt]
[clojure.spec.alpha :as s]))
;; --- SPECS
(s/def ::changes
(s/coll-of map? :kind vector?))
(s/def ::hint-origin ::us/keyword)
(s/def ::hint-events
(s/every ::us/keyword :kind vector?))
(s/def ::change-with-metadata
(s/keys :req-un [::changes]
:opt-un [::hint-origin
::hint-events]))
(s/def ::changes-with-metadata
(s/every ::change-with-metadata :kind vector?))
(s/def ::session-id ::us/uuid)
(s/def ::revn ::us/integer)
(s/def ::update-file
(s/and
(s/keys :req [::rpc/profile-id]
:req-un [::files/id ::session-id ::revn]
:opt-un [::changes ::changes-with-metadata ::features])
(fn [o]
(or (contains? o :changes)
(contains? o :changes-with-metadata)))))
[app.util.time :as dt]))
;; --- SCHEMA
@ -177,6 +146,7 @@
(db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id id)
(db/xact-lock! conn id)
(let [cfg (assoc cfg ::db/conn conn)
params (assoc params :profile-id profile-id)
tpoint (dt/tpoint)]

2
backend/src/app/rpc/commands/management.clj
View File

@ -9,7 +9,7 @@
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.pages.migrations :as pmg]
[app.common.files.migrations :as pmg]
[app.common.schema :as sm]
[app.common.spec :as us]
[app.common.uuid :as uuid]

2
backend/src/app/rpc/commands/viewer.clj
View File

@ -83,7 +83,7 @@
[:map {:title "get-view-only-bundle"}
[:file-id ::sm/uuid]
[:share-id {:optional true} ::sm/uuid]
[:features {:optional true} ::files/features]])
[:features {:optional true} files/schema:features]])
(sv/defmethod ::get-view-only-bundle
{::rpc/auth false

2
backend/src/app/srepl/helpers.clj
View File

@ -14,7 +14,7 @@
[app.common.files.features :as ffeat]
[app.common.logging :as l]
[app.common.pages :as cp]
[app.common.pages.migrations :as pmg]
[app.common.files.migrations :as pmg]
[app.common.pprint :refer [pprint]]
[app.common.spec :as us]
[app.common.uuid :as uuid]

2
backend/src/app/tasks/file_gc.clj
View File

@ -11,8 +11,8 @@
inactivity (the default threshold is 72h)."
(:require
[app.common.data :as d]
[app.common.files.migrations :as pmg]
[app.common.logging :as l]
[app.common.pages.migrations :as pmg]
[app.common.types.components-list :as ctkl]
[app.common.types.file :as ctf]
[app.common.types.shape-tree :as ctt]

113
backend/src/app/util/async.clj
View File

@ -1,113 +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) KALEIDOS INC
(ns app.util.async
(:require
[app.common.exceptions :as ex]
[clojure.core.async :as a]
[clojure.core.async.impl.protocols :as ap]
[clojure.spec.alpha :as s])
(:import
java.util.concurrent.Executor
java.util.concurrent.RejectedExecutionException))
(s/def ::executor #(instance? Executor %))
(s/def ::channel #(satisfies? ap/Channel %))
(defonce processors
(delay (.availableProcessors (Runtime/getRuntime))))
(defmacro go-try
[& body]
`(a/go
(try
~@body
(catch Exception e# e#))))
(defmacro thread
[& body]
`(a/thread
(try
~@body
(catch Exception e#
e#))))
(defmacro <?
[ch]
`(let [r# (a/<! ~ch)]
(if (instance? Exception r#)
(throw r#)
r#)))
(defmacro with-closing
[ch & body]
`(try
~@body
(finally
(some-> ~ch a/close!))))
(defn thread-call
[^Executor executor f]
(let [ch (a/chan 1)
f' (fn []
(try
(let [ret (ex/try* f identity)]
(when (some? ret) (a/>!! ch ret)))
(finally
(a/close! ch))))]
(try
(.execute executor f')
(catch RejectedExecutionException _cause
(a/close! ch)))
ch))
(defmacro with-thread
[executor & body]
(if (= executor ::default)
`(a/thread-call (^:once fn* [] (try ~@body (catch Exception e# e#))))
`(thread-call ~executor (^:once fn* [] ~@body))))
(defn batch
[in {:keys [max-batch-size
max-batch-age
buffer-size
init]
:or {max-batch-size 200
max-batch-age (* 30 1000)
buffer-size 128
init #{}}
:as opts}]
(let [out (a/chan buffer-size)]
(a/go-loop [tch (a/timeout max-batch-age) buf init]
(let [[val port] (a/alts! [tch in])]
(cond
(identical? port tch)
(if (empty? buf)
(recur (a/timeout max-batch-age) buf)
(do
(a/>! out [:timeout buf])
(recur (a/timeout max-batch-age) init)))
(nil? val)
(if (empty? buf)
(a/close! out)
(do
(a/offer! out [:timeout buf])
(a/close! out)))
(identical? port in)
(let [buf (conj buf val)]
(if (>= (count buf) max-batch-size)
(do
(a/>! out [:size buf])
(recur (a/timeout max-batch-age) init))
(recur tch buf))))))
out))
(defn thread-sleep
[ms]
(Thread/sleep (long ms)))

93
backend/test/backend_tests/rpc_file_test.clj
View File

@ -7,6 +7,7 @@
(ns backend-tests.rpc-file-test
(:require
[app.common.uuid :as uuid]
[app.common.types.shape :as cts]
[app.db :as db]
[app.db.sql :as sql]
[app.http :as http]
@ -187,11 +188,12 @@
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj {:id shape-id
:name "image"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect}}])
:obj (cts/setup-shape
{:id shape-id
:name "image"
:frame-id uuid/zero
:parent-id uuid/zero
:type :rect})}])
;; Check the number of fragments
(let [rows (th/db-query :file-data-fragment {:file-id (:id file)})]
@ -282,12 +284,13 @@
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj {:id shid
:name "image"
:frame-id uuid/zero
:parent-id uuid/zero
:type :image
:metadata {:id (:id fmo1) :width 200 :height 200 :mtype "image/jpeg"}}}])
:obj (cts/setup-shape
{:id shid
:name "image"
:frame-id uuid/zero
:parent-id uuid/zero
:type :image
:metadata {:id (:id fmo1) :width 100 :height 100 :mtype "image/jpeg"}})}])
;; Check that reference storage objects on filemediaobjects
;; are the same because of deduplication feature.
@ -547,38 +550,42 @@
shape2-id (uuid/next)
changes [{:type :add-obj
:page-id page-id
:id frame1-id
:parent-id uuid/zero
:frame-id uuid/zero
:obj {:id frame1-id
:use-for-thumbnail? true
:name "test-frame1"
:type :frame}}
{:type :add-obj
:page-id page-id
:id shape1-id
:parent-id frame1-id
:frame-id frame1-id
:obj {:id shape1-id
:name "test-shape1"
:type :rect}}
{:type :add-obj
:page-id page-id
:id frame2-id
:parent-id uuid/zero
:frame-id uuid/zero
:obj {:id frame2-id
:name "test-frame2"
:type :frame}}
{:type :add-obj
:page-id page-id
:id shape2-id
:parent-id frame2-id
:frame-id frame2-id
:obj {:id shape2-id
:name "test-shape2"
:type :rect}}]]
:page-id page-id
:id frame1-id
:parent-id uuid/zero
:frame-id uuid/zero
:obj (cts/setup-shape
{:id frame1-id
:use-for-thumbnail? true
:name "test-frame1"
:type :frame})}
{:type :add-obj
:page-id page-id
:id shape1-id
:parent-id frame1-id
:frame-id frame1-id
:obj (cts/setup-shape
{:id shape1-id
:name "test-shape1"
:type :rect})}
{:type :add-obj
:page-id page-id
:id frame2-id
:parent-id uuid/zero
:frame-id uuid/zero
:obj (cts/setup-shape
{:id frame2-id
:name "test-frame2"
:type :frame})}
{:type :add-obj
:page-id page-id
:id shape2-id
:parent-id frame2-id
:frame-id frame2-id
:obj (cts/setup-shape
{:id shape2-id
:name "test-shape2"
:type :rect})}]]
;; Update the file
(th/update-file* {:file-id (:id file)
:profile-id (:id prof)

12
backend/test/backend_tests/rpc_file_thumbnails_test.clj
View File

@ -7,6 +7,7 @@
(ns backend-tests.rpc-file-thumbnails-test
(:require
[app.common.uuid :as uuid]
[app.common.types.shape :as cts]
[app.config :as cf]
[app.db :as db]
[app.rpc :as-alias rpc]
@ -46,11 +47,12 @@
:parent-id uuid/zero
:frame-id uuid/zero
:components-v2 true
:obj {:id shid
:name "Artboard"
:frame-id uuid/zero
:parent-id uuid/zero
:type :frame}}])
:obj (cts/setup-shape
{:id shid
:name "Artboard"
:frame-id uuid/zero
:parent-id uuid/zero
:type :frame})}])
data1 {::th/type :create-file-object-thumbnail
::rpc/profile-id (:id profile)

7
common/dev/user.clj
View File

@ -6,13 +6,18 @@
(ns user
(:require
[app.common.schema :as sm]
[app.common.schema.desc-js-like :as smdj]
[app.common.schema.desc-native :as smdn]
[app.common.schema.generators :as sg]
[app.common.pprint :as pp]
[clojure.java.io :as io]
[clojure.pprint :refer [pprint print-table]]
[clojure.repl :refer :all]
[clojure.spec.alpha :as s]
[clojure.spec.gen.alpha :as sgen]
[clojure.test :as test]
[clojure.test.check.generators :as gen]
[clojure.test.check.generators :as tgen]
[clojure.tools.namespace.repl :as repl]
[clojure.walk :refer [macroexpand-all]]
[criterium.core :as crit]))

8
common/package.json
View File

@ -7,10 +7,10 @@
"luxon": "^3.3.0"
},
"scripts": {
"compile-and-watch-test": "clojure -M:dev:shadow-cljs watch test",
"compile-test": "clojure -M:dev:shadow-cljs compile test --config-merge '{:autorun false}'",
"run-test": "node target/test.js",
"test": "yarn run compile-test && yarn run run-test"
"test:watch": "clojure -M:dev:shadow-cljs watch test",
"test:compile": "clojure -M:dev:shadow-cljs compile test --config-merge '{:autorun false}'",
"test:run": "node target/test.js",
"test": "yarn run test:compile && yarn run test:run"
},
"devDependencies": {
"shadow-cljs": "2.20.16",

5
common/src/app/common/attrs.cljc
View File

@ -6,7 +6,7 @@
(ns app.common.attrs
(:require
[app.common.geom.shapes.transforms :as gtr]
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]))
(defn- get-attr
@ -24,7 +24,8 @@
value
(if-let [points (:points obj)]
(if (not= points :multiple)
(let [rect (gtr/selection-rect [obj])]
;; FIXME: consider using gsh/shape->rect ??
(let [rect (gsh/shapes->rect [obj])]
(if (= attr :ox) (:x rect) (:y rect)))
:multiple)
(get obj attr ::unset)))

54
common/src/app/common/data.cljc
View File

@ -9,7 +9,7 @@
data resources."
(:refer-clojure :exclude [read-string hash-map merge name update-vals
parse-double group-by iteration concat mapcat
parse-uuid])
parse-uuid max min])
#?(:cljs
(:require-macros [app.common.data]))
@ -590,23 +590,47 @@
([a]
(mth/finite? a))
([a b]
(and (mth/finite? a)
(mth/finite? b)))
(and ^boolean (mth/finite? a)
^boolean (mth/finite? b)))
([a b c]
(and (mth/finite? a)
(mth/finite? b)
(mth/finite? c)))
(and ^boolean (mth/finite? a)
^boolean (mth/finite? b)
^boolean (mth/finite? c)))
([a b c d]
(and (mth/finite? a)
(mth/finite? b)
(mth/finite? c)
(mth/finite? d)))
(and ^boolean (mth/finite? a)
^boolean (mth/finite? b)
^boolean (mth/finite? c)
^boolean (mth/finite? d)))
([a b c d & others]
(and (mth/finite? a)
(mth/finite? b)
(mth/finite? c)
(mth/finite? d)
(every? mth/finite? others))))
(and ^boolean (mth/finite? a)
^boolean (mth/finite? b)
^boolean (mth/finite? c)
^boolean (mth/finite? d)
^boolean (every? mth/finite? others))))
(defn safe+
[a b]
(if (mth/finite? a) (+ a b) a))
(defn max
([a] a)
([a b] (mth/max a b))
([a b c] (mth/max a b c))
([a b c d] (mth/max a b c d))
([a b c d e] (mth/max a b c d e))
([a b c d e f] (mth/max a b c d e f))
([a b c d e f & other]
(reduce max (mth/max a b c d e f) other)))
(defn min
([a] a)
([a b] (mth/min a b))
([a b c] (mth/min a b c))
([a b c d] (mth/min a b c d))
([a b c d e] (mth/min a b c d e))
([a b c d e f] (mth/min a b c d e f))
([a b c d e f & other]
(reduce min (mth/min a b c d e f) other)))
(defn check-num
"Function that checks if a number is nil or nan. Will return 0 when not

11
common/src/app/common/data/macros.cljc
View File

@ -7,7 +7,7 @@
#_:clj-kondo/ignore
(ns app.common.data.macros
"Data retrieval & manipulation specific macros."
(:refer-clojure :exclude [get-in select-keys str with-open])
(:refer-clojure :exclude [get-in select-keys str with-open min max])
#?(:cljs (:require-macros [app.common.data.macros]))
(:require
#?(:clj [clojure.core :as c]
@ -120,13 +120,10 @@
"A macro based, optimized variant of `get` that access the property
directly on CLJS, on CLJ works as get."
[obj prop]
;; `(do
;; (when-not (record? ~obj)
;; (js/console.trace (pr-str ~obj)))
;; (c/get ~obj ~prop)))
(if (:ns &env)
(list (symbol ".") (with-meta obj {:tag 'js}) (symbol (str "-" (c/name prop))))
`(c/get ~obj ~prop)))
(list `c/get obj prop)))
(def ^:dynamic *assert-context* nil)
@ -154,7 +151,7 @@
(defmacro verify!
([expr]
`(assert! nil ~expr))
`(verify! nil ~expr))
([hint expr]
(let [hint (cond
(vector? hint)

5
common/src/app/common/exceptions.cljc
View File

@ -32,11 +32,6 @@
[& params]
`(throw (error ~@params)))
;; FIXME deprecate
(defn try*
[f on-error]
(try (f) (catch #?(:clj Throwable :cljs :default) e (on-error e))))
;; http://clj-me.cgrand.net/2013/09/11/macros-closures-and-unexpected-object-retention/
;; Explains the use of ^:once metadata

184
common/src/app/common/file_builder.cljc → common/src/app/common/files/builder.cljc
View File

@ -4,14 +4,13 @@
;;
;; Copyright (c) KALEIDOS INC
(ns app.common.file-builder
"A version parsing helper."
(ns app.common.files.builder
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.pages.changes :as ch]
[app.common.pprint :as pp]
@ -25,9 +24,9 @@
[app.common.uuid :as uuid]
[cuerdas.core :as str]))
(def root-frame uuid/zero)
(def conjv (fnil conj []))
(def conjs (fnil conj #{}))
(def ^:private root-id uuid/zero)
(def ^:private conjv (fnil conj []))
(def ^:private conjs (fnil conj #{}))
(defn- commit-change
([file change]
@ -38,35 +37,33 @@
:or {add-container? false
fail-on-spec? false}}]
(let [component-id (:current-component-id file)
change (cond-> change
(and add-container? (some? component-id))
(cond->
:always
(assoc :component-id component-id)
change (cond-> change
(and add-container? (some? component-id))
(-> (assoc :component-id component-id)
(cond-> (some? (:current-frame-id file))
(assoc :frame-id (:current-frame-id file))))
(some? (:current-frame-id file))
(assoc :frame-id (:current-frame-id file)))
(and add-container? (nil? component-id))
(assoc :page-id (:current-page-id file)
:frame-id (:current-frame-id file)))
valid? (ch/valid-change? change)]
(and add-container? (nil? component-id))
(assoc :page-id (:current-page-id file)
:frame-id (:current-frame-id file)))]
(when-not valid?
(let [explain (sm/explain ::ch/change change)]
(pp/pprint (sm/humanize-data explain))
(when fail-on-spec?
(ex/raise :type :assertion
:code :data-validation
:hint "invalid change"
::sm/explain explain))))
(when fail-on-spec?
(dm/verify! (ch/change? change)))
(cond-> file
valid?
(-> (update :changes conjv change)
(update :data ch/process-changes [change] false))
(let [valid? (ch/change? change)]
(when-not valid?
(pp/pprint change {:level 100})
(sm/pretty-explain ::ch/change change))
(cond-> file
valid?
(-> (update :changes conjv change)
(update :data ch/process-changes [change] false))
(not valid?)
(update :errors conjv change))))))
(not valid?)
(update :errors conjv change)))))
(defn- lookup-objects
([file]
@ -91,50 +88,6 @@
(commit-change file change {:add-container? true :fail-on-spec? fail-on-spec?})))
(defn setup-rect-selrect [{:keys [x y width height transform] :as obj}]
(when-not (d/num? x y width height)
(ex/raise :type :assertion
:code :invalid-condition
:hint "Coords not valid for object"))
(let [rect (gsh/make-rect x y width height)
center (gsh/center-rect rect)
selrect (gsh/rect->selrect rect)
points (-> (gsh/rect->points rect)
(gsh/transform-points center transform))]
(-> obj
(assoc :selrect selrect)
(assoc :points points))))
(defn- setup-path-selrect
[{:keys [content center transform transform-inverse] :as obj}]
(when (or (empty? content) (nil? center))
(ex/raise :type :assertion
:code :invalid-condition
:hint "Path not valid"))
(let [transform (gmt/transform-in center transform)
transform-inverse (gmt/transform-in center transform-inverse)
content' (gsh/transform-content content transform-inverse)
selrect (gsh/content->selrect content')
points (-> (gsh/rect->points selrect)
(gsh/transform-points transform))]
(-> obj
(dissoc :center)
(assoc :selrect selrect)
(assoc :points points))))
(defn- setup-selrect
[obj]
(if (= (:type obj) :path)
(setup-path-selrect obj)
(setup-rect-selrect obj)))
(defn- generate-name
[type data]
(if (= type :svg-raw)
@ -203,10 +156,10 @@
(assoc :current-page-id page-id)
;; Current frame-id
(assoc :current-frame-id root-frame)
(assoc :current-frame-id root-id)
;; Current parent stack we'll be nesting
(assoc :parent-stack [root-frame])
(assoc :parent-stack [root-id])
;; Last object id added
(assoc :last-id nil))))
@ -220,11 +173,8 @@
(clear-names)))
(defn add-artboard [file data]
(let [obj (-> (cts/make-minimal-shape :frame)
(merge data)
(check-name file :frame)
(setup-selrect)
(d/without-nils))]
(let [obj (-> (cts/setup-shape (assoc data :type :frame))
(check-name file :frame))]
(-> file
(commit-shape obj)
(assoc :current-frame-id (:id obj))
@ -237,19 +187,15 @@
parent (lookup-shape file parent-id)
current-frame-id (or (:frame-id parent)
(when (nil? (:current-component-id file))
root-frame))]
root-id))]
(-> file
(assoc :current-frame-id current-frame-id)
(update :parent-stack pop))))
(defn add-group [file data]
(let [frame-id (:current-frame-id file)
selrect cts/empty-selrect
name (:name data)
obj (-> (cts/make-minimal-group frame-id selrect name)
(merge data)
(check-name file :group)
(d/without-nils))]
obj (-> (cts/setup-shape (assoc data :type :group :frame-id frame-id))
(check-name file :group))]
(-> file
(commit-shape obj)
(assoc :last-id (:id obj))
@ -271,7 +217,7 @@
:id group-id}
{:add-container? true})
(:masked-group? group)
(:masked-group group)
(let [mask (first children)]
(commit-change
file
@ -309,15 +255,8 @@
(defn add-bool [file data]
(let [frame-id (:current-frame-id file)
name (:name data)
obj (-> {:id (uuid/next)
:type :bool
:name name
:shapes []
:frame-id frame-id}
(merge data)
(check-name file :bool)
(d/without-nils))]
obj (-> (cts/setup-shape (assoc data :type :bool :frame-id frame-id))
(check-name file :bool))]
(-> file
(commit-shape obj)
(assoc :last-id (:id obj))
@ -360,11 +299,8 @@
(update :parent-stack pop))))
(defn create-shape [file type data]
(let [obj (-> (cts/make-minimal-shape type)
(merge data)
(check-name file :type)
(setup-selrect)
(d/without-nils))]
(let [obj (-> (cts/setup-shape (assoc data :type type))
(check-name file :type))]
(-> file
(commit-shape obj)
(assoc :last-id (:id obj))
@ -556,23 +492,33 @@
{:type :del-media
:id id}))))
(defn start-component
([file data] (start-component file data :group))
([file data root-type]
(let [selrect (or (gsh/make-selrect (:x data) (:y data) (:width data) (:height data))
cts/empty-selrect)
;; FIXME: data probably can be a shape instance, then we can use gsh/shape->rect
(let [selrect (or (grc/make-rect (:x data) (:y data) (:width data) (:height data))
grc/empty-rect)
name (:name data)
path (:path data)
main-instance-id (:main-instance-id data)
main-instance-page (:main-instance-page data)
obj (-> (cts/make-shape root-type selrect data)
(dissoc :path
:main-instance-id
:main-instance-page
:main-instance-x
:main-instance-y)
(check-name file root-type)
(d/without-nils))]
attrs (-> data
(assoc :type root-type)
(assoc :x (:x selrect))
(assoc :y (:y selrect))
(assoc :width (:width selrect))
(assoc :height (:height selrect))
(assoc :selrect selrect)
(dissoc :path)
(dissoc :main-instance-id)
(dissoc :main-instance-page)
(dissoc :main-instance-x)
(dissoc :main-instance-y))
obj (-> (cts/setup-shape attrs)
(check-name file root-type))]
(-> file
(commit-change
{:type :add-component
@ -604,7 +550,7 @@
:id component-id
:skip-undelete? true})
(:masked-group? component)
(:masked-group component)
(let [mask (first children)]
(commit-change
file
@ -660,7 +606,7 @@
(gpt/point main-instance-x
main-instance-y)
true
{:main-instance? true
{:main-instance true
:force-id main-instance-id})]
(as-> file $
(reduce #(commit-change %1
@ -703,7 +649,7 @@
(gpt/point x
y)
components-v2
#_{:main-instance? true
#_{:main-instance true
:force-id main-instance-id})]
(as-> file $
@ -734,8 +680,8 @@
(defn update-object
[file old-obj new-obj]
(let [page-id (:current-page-id file)
new-obj (setup-selrect new-obj)
attrs (d/concat-set (keys old-obj) (keys new-obj))
new-obj (cts/setup-shape new-obj)
attrs (d/concat-set (keys old-obj) (keys new-obj))
generate-operation
(fn [changes attr]
(let [old-val (get old-obj attr)

9
common/src/app/common/files/defaults.cljc Normal file
View File

@ -0,0 +1,9 @@
;; 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) KALEIDOS INC
(ns app.common.files.defaults)
(def version 23)

46
common/src/app/common/files/helpers.cljc Normal file
View File

@ -0,0 +1,46 @@
;; 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) KALEIDOS INC
(ns app.common.files.helpers
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.schema :as sm]))
(defn get-used-names
"Return a set with the all unique names used in the
elements (any entity thas has a :name)"
[elements]
(let [elements (if (map? elements)
(vals elements)
elements)]
(into #{} (keep :name) elements)))
(defn- extract-numeric-suffix
[basename]
(if-let [[_ p1 p2] (re-find #"(.*) ([0-9]+)$" basename)]
[p1 (+ 1 (d/parse-integer p2))]
[basename 1]))
(defn generate-unique-name
"A unique name generator"
[used basename]
(dm/assert!
"expected a set of strings"
(sm/set-of-strings? used))
(dm/assert!
"expected a string for `basename`."
(string? basename))
(if-not (contains? used basename)
basename
(let [[prefix initial] (extract-numeric-suffix basename)]
(loop [counter initial]
(let [candidate (str prefix " " counter)]
(if (contains? used candidate)
(recur (inc counter))
candidate))))))

87
common/src/app/common/pages/migrations.cljc → common/src/app/common/files/migrations.cljc
View File

@ -4,30 +4,30 @@
;;
;; Copyright (c) KALEIDOS INC
(ns app.common.pages.migrations
(ns app.common.files.migrations
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.files.defaults :refer [version]]
[app.common.geom.matrix :as gmt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.geom.shapes.path :as gsp]
[app.common.geom.shapes.text :as gsht]
[app.common.logging :as log]
[app.common.math :as mth]
[app.common.pages :as cp]
[app.common.pages.changes :as cpc]
[app.common.pages.helpers :as cph]
[app.common.types.shape :as cts]
[app.common.uuid :as uuid]
[cuerdas.core :as str]))
;; TODO: revisit this and rename to file-migrations
#?(:cljs (log/set-level! :info))
(defmulti migrate :version)
(log/set-level! :info)
(defn migrate-data
([data] (migrate-data data cp/file-version))
([data] (migrate-data data version))
([data to-version]
(if (= (:version data) to-version)
data
@ -74,7 +74,7 @@
(if-not (contains? shape :content)
(let [content (gsp/segments->content (:segments shape) (:close? shape))
selrect (gsh/content->selrect content)
points (gsh/rect->points selrect)]
points (grc/rect->points selrect)]
(-> shape
(dissoc :segments)
(dissoc :close?)
@ -87,17 +87,17 @@
(fix-frames-selrects [frame]
(if (= (:id frame) uuid/zero)
frame
(let [frame-rect (select-keys frame [:x :y :width :height])]
(let [selrect (gsh/shape->rect frame)]
(-> frame
(assoc :selrect (gsh/rect->selrect frame-rect))
(assoc :points (gsh/rect->points frame-rect))))))
(assoc :selrect selrect)
(assoc :points (grc/rect->points selrect))))))
(fix-empty-points [shape]
(let [shape (cond-> shape
(empty? (:selrect shape)) (cts/setup-rect-selrect))]
(empty? (:selrect shape)) (cts/setup-rect))]
(cond-> shape
(empty? (:points shape))
(assoc :points (gsh/rect->points (:selrect shape))))))
(assoc :points (grc/rect->points (:selrect shape))))))
(update-object [object]
(cond-> object
@ -141,10 +141,10 @@
;; Fixes issues with selrect/points for shapes with width/height = 0 (line-like paths)"
(letfn [(fix-line-paths [shape]
(if (= (:type shape) :path)
(let [{:keys [width height]} (gsh/points->rect (:points shape))]
(let [{:keys [width height]} (grc/points->rect (:points shape))]
(if (or (mth/almost-zero? width) (mth/almost-zero? height))
(let [selrect (gsh/content->selrect (:content shape))
points (gsh/rect->points selrect)
points (grc/rect->points selrect)
transform (gmt/matrix)
transform-inv (gmt/matrix)]
(assoc shape
@ -242,7 +242,7 @@
(loop [data data]
(let [changes (mapcat calculate-changes (:pages-index data))]
(if (seq changes)
(recur (cp/process-changes data changes))
(recur (cpc/process-changes data changes))
data)))))
(defmethod migrate 10
@ -462,5 +462,58 @@
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
;; TODO: pending to do a migration for delete already not used fill
;; and stroke props. This should be done for >1.14.x version.
(defmethod migrate 21
[data]
(letfn [(update-object [object]
(-> object
(d/update-when :selrect grc/make-rect)
(cts/map->Shape)))
(update-container [container]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
(defmethod migrate 22
[data]
(letfn [(update-object [object]
(cond-> object
(nil? (:transform object))
(assoc :transform (gmt/matrix))
(nil? (:transform-inverse object))
(assoc :transform-inverse (gmt/matrix))))
(update-container [container]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))
(defmethod migrate 23
[data]
(letfn [(update-object [object]
(cond-> object
(contains? object :main-instance?)
(-> (assoc :main-instance (:main-instance? object))
(dissoc :main-instance?))
(contains? object :component-root?)
(-> (assoc :component-root (:component-root? object))
(dissoc :component-root?))
(contains? object :remote-synced?)
(-> (assoc :remote-synced (:remote-synced? object))
(dissoc :remote-synced?))
(contains? object :masked-group?)
(-> (assoc :masked-group (:masked-group? object))
(dissoc :masked-group?))))
(update-container [container]
(d/update-when container :objects update-vals update-object))]
(-> data
(update :pages-index update-vals update-container)
(update :components update-vals update-container))))

40
common/src/app/common/fressian.clj
View File

@ -7,12 +7,8 @@
(ns app.common.fressian
(:require
[app.common.data :as d]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[clojure.data.fressian :as fres])
(:import
app.common.geom.matrix.Matrix
app.common.geom.point.Point
clojure.lang.Ratio
java.io.ByteArrayInputStream
java.io.ByteArrayOutputStream
@ -297,39 +293,3 @@
[data]
(with-open [^ByteArrayInputStream input (ByteArrayInputStream. ^bytes data)]
(-> input reader read!)))
;; --- ADDITIONAL
(add-handlers!
{:name "penpot/point"
:class app.common.geom.point.Point
:wfn (fn [n w ^Point o]
(write-tag! w n 1)
(write-list! w (List/of (.-x o) (.-y o))))
:rfn (fn [^Reader rdr]
(let [^List x (read-object! rdr)]
(Point. (.get x 0) (.get x 1))))}
{:name "penpot/matrix"
:class app.common.geom.matrix.Matrix
:wfn (fn [^String n ^Writer w o]
(write-tag! w n 1)
(write-list! w (List/of (.-a ^Matrix o)
(.-b ^Matrix o)
(.-c ^Matrix o)
(.-d ^Matrix o)
(.-e ^Matrix o)
(.-f ^Matrix o))))
:rfn (fn [^Reader rdr]
(let [^List x (read-object! rdr)]
(Matrix. (.get x 0) (.get x 1) (.get x 2) (.get x 3) (.get x 4) (.get x 5))))})
;; Backward compatibility for 1.19 with v1.20;
(add-handlers!
{:name "penpot/geom/rect"
:rfn read-map-like}
{:name "penpot/shape"
:rfn read-map-like})

55
common/src/app/common/geom/align.cljc
View File

@ -6,6 +6,7 @@
(ns app.common.geom.align
(:require
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.pages.helpers :refer [get-children]]))
@ -30,7 +31,7 @@
the shape with the given rectangle. If the shape is a group,
move also all of its recursive children."
[shape rect axis objects]
(let [wrapper-rect (gsh/selection-rect [shape])
(let [wrapper-rect (gsh/shapes->rect [shape])
align-pos (calc-align-pos wrapper-rect rect axis)
delta {:x (- (:x align-pos) (:x wrapper-rect))
:y (- (:y align-pos) (:y wrapper-rect))}]
@ -78,11 +79,11 @@
other-coord (if (= axis :horizontal) :y :x)
size (if (= axis :horizontal) :width :height)
; The rectangle that wraps the whole selection
wrapper-rect (gsh/selection-rect shapes)
wrapper-rect (gsh/shapes->rect shapes)
; Sort shapes by the center point in the given axis
sorted-shapes (sort-by #(coord (gsh/center-shape %)) shapes)
sorted-shapes (sort-by #(coord (gsh/shape->center %)) shapes)
; Each shape wrapped in its own rectangle
wrapped-shapes (map #(gsh/selection-rect [%]) sorted-shapes)
wrapped-shapes (map #(gsh/shapes->rect [%]) sorted-shapes)
; The total space between shapes
space (reduce - (size wrapper-rect) (map size wrapped-shapes))
unit-space (/ space (- (count wrapped-shapes) 1))
@ -111,28 +112,32 @@
(defn adjust-to-viewport
([viewport srect] (adjust-to-viewport viewport srect nil))
([viewport srect {:keys [padding] :or {padding 0}}]
(let [gprop (/ (:width viewport) (:height viewport))
srect (-> srect
(update :x #(- % padding))
(update :y #(- % padding))
(update :width #(+ % padding padding))
(update :height #(+ % padding padding)))
width (:width srect)
(let [gprop (/ (:width viewport)
(:height viewport))
srect (-> srect
(update :x #(- % padding))
(update :y #(- % padding))
(update :width #(+ % padding padding))
(update :height #(+ % padding padding)))
width (:width srect)
height (:height srect)
lprop (/ width height)]
lprop (/ width height)]
(cond
(> gprop lprop)
(let [width' (* (/ width lprop) gprop)
padding (/ (- width' width) 2)]
(-> srect
(update :x #(- % padding))
(assoc :width width')))
(> gprop lprop)
(let [width' (* (/ width lprop) gprop)
padding (/ (- width' width) 2)]
(-> srect
(update :x #(- % padding))
(assoc :width width')
(grc/update-rect :position)))
(< gprop lprop)
(let [height' (/ (* height lprop) gprop)
padding (/ (- height' height) 2)]
(-> srect
(update :y #(- % padding))
(assoc :height height')))
(< gprop lprop)
(let [height' (/ (* height lprop) gprop)
padding (/ (- height' height) 2)]
(-> srect
(update :y #(- % padding))
(assoc :height height')
(grc/update-rect :position)))
:else srect))))
:else
(grc/update-rect srect :position)))))

2
frontend/src/app/util/geom/grid.cljs → common/src/app/common/geom/grid.cljc
View File

@ -4,7 +4,7 @@
;;
;; Copyright (c) KALEIDOS INC
(ns app.util.geom.grid
(ns app.common.geom.grid
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]

235
common/src/app/common/geom/matrix.cljc
View File

@ -8,34 +8,41 @@
(:require
#?(:cljs [cljs.pprint :as pp]
:clj [clojure.pprint :as pp])
#?(:clj [app.common.fressian :as fres])
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.math :as mth]
[app.common.record :as cr]
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
[app.common.schema.openapi :as-alias oapi]
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
[app.common.transit :as t]
[clojure.spec.alpha :as s])
#?(:clj
(:import
java.util.List)))
(def precision 6)
;; --- Matrix Impl
(defrecord Matrix [^double a
^double b
^double c
^double d
^double e
^double f]
(cr/defrecord Matrix [^double a
^double b
^double c
^double d
^double e
^double f]
Object
(toString [_]
(toString [this]
(dm/fmt "matrix(%, %, %, %, %, %)"
(mth/to-fixed a precision)
(mth/to-fixed b precision)
(mth/to-fixed c precision)
(mth/to-fixed d precision)
(mth/to-fixed e precision)
(mth/to-fixed f precision))))
(mth/to-fixed (.-a this) precision)
(mth/to-fixed (.-b this) precision)
(mth/to-fixed (.-c this) precision)
(mth/to-fixed (.-d this) precision)
(mth/to-fixed (.-e this) precision)
(mth/to-fixed (.-f this) precision))))
(defn matrix?
"Return true if `v` is Matrix instance."
@ -45,9 +52,9 @@
(defn matrix
"Create a new matrix instance."
([]
(Matrix. 1 0 0 1 0 0))
(pos->Matrix 1 0 0 1 0 0))
([a b c d e f]
(Matrix. a b c d e f)))
(pos->Matrix a b c d e f)))
(def number-regex #"[+-]?\d*(\.\d+)?(e[+-]?\d+)?")
@ -94,7 +101,7 @@
(sg/small-double)
(sg/small-double)
(sg/small-double) )
(sg/fmap #(apply ->Matrix %)))
(sg/fmap #(apply pos->Matrix %)))
::oapi/type "string"
::oapi/format "matrix"
::oapi/decode decode
@ -114,24 +121,54 @@
(s/def ::matrix
(s/and ::matrix-attrs matrix?))
(defn close?
[^Matrix m1 ^Matrix m2]
(and (mth/close? (.-a m1) (.-a m2))
(mth/close? (.-b m1) (.-b m2))
(mth/close? (.-c m1) (.-c m2))
(mth/close? (.-d m1) (.-d m2))
(mth/close? (.-e m1) (.-e m2))
(mth/close? (.-f m1) (.-f m2))))
(and ^boolean (mth/close? (.-a m1) (.-a m2))
^boolean (mth/close? (.-b m1) (.-b m2))
^boolean (mth/close? (.-c m1) (.-c m2))
^boolean (mth/close? (.-d m1) (.-d m2))
^boolean (mth/close? (.-e m1) (.-e m2))
^boolean (mth/close? (.-f m1) (.-f m2))))
(defn unit? [^Matrix m1]
(and (some? m1)
(mth/close? (.-a m1) 1)
(mth/close? (.-b m1) 0)
(mth/close? (.-c m1) 0)
(mth/close? (.-d m1) 1)
(mth/close? (.-e m1) 0)
(mth/close? (.-f m1) 0)))
(and ^boolean (some? m1)
^boolean (mth/close? (.-a m1) 1)
^boolean (mth/close? (.-b m1) 0)
^boolean (mth/close? (.-c m1) 0)
^boolean (mth/close? (.-d m1) 1)
^boolean (mth/close? (.-e m1) 0)
^boolean (mth/close? (.-f m1) 0)))
(defn multiply!
[^Matrix m1 ^Matrix m2]
(let [m1a (.-a m1)
m1b (.-b m1)
m1c (.-c m1)
m1d (.-d m1)
m1e (.-e m1)
m1f (.-f m1)
m2a (.-a m2)
m2b (.-b m2)
m2c (.-c m2)
m2d (.-d m2)
m2e (.-e m2)
m2f (.-f m2)]
#?@(:cljs
[(set! (.-a m1) (+ (* m1a m2a) (* m1c m2b)))
(set! (.-b m1) (+ (* m1b m2a) (* m1d m2b)))
(set! (.-c m1) (+ (* m1a m2c) (* m1c m2d)))
(set! (.-d m1) (+ (* m1b m2c) (* m1d m2d)))
(set! (.-e m1) (+ (* m1a m2e) (* m1c m2f) m1e))
(set! (.-f m1) (+ (* m1b m2e) (* m1d m2f) m1f))
m1]
:clj
[(pos->Matrix
(+ (* m1a m2a) (* m1c m2b))
(+ (* m1b m2a) (* m1d m2b))
(+ (* m1a m2c) (* m1c m2d))
(+ (* m1b m2c) (* m1d m2d))
(+ (* m1a m2e) (* m1c m2f) m1e)
(+ (* m1b m2e) (* m1d m2f) m1f))])))
(defn multiply
([^Matrix m1 ^Matrix m2]
@ -156,7 +193,7 @@
m2e (.-e m2)
m2f (.-f m2)]
(Matrix.
(pos->Matrix
(+ (* m1a m2a) (* m1c m2b))
(+ (* m1b m2a) (* m1d m2b))
(+ (* m1a m2c) (* m1c m2d))
@ -165,51 +202,28 @@
(+ (* m1b m2e) (* m1d m2f) m1f)))))
([m1 m2 & others]
(reduce multiply (multiply m1 m2) others)))
(defn multiply!
[^Matrix m1 ^Matrix m2]
(let [m1a (.-a m1)
m1b (.-b m1)
m1c (.-c m1)
m1d (.-d m1)
m1e (.-e m1)
m1f (.-f m1)
m2a (.-a m2)
m2b (.-b m2)
m2c (.-c m2)
m2d (.-d m2)
m2e (.-e m2)
m2f (.-f m2)]
#?@(:cljs [(set! (.-a m1) (+ (* m1a m2a) (* m1c m2b)))
(set! (.-b m1) (+ (* m1b m2a) (* m1d m2b)))
(set! (.-c m1) (+ (* m1a m2c) (* m1c m2d)))
(set! (.-d m1) (+ (* m1b m2c) (* m1d m2d)))
(set! (.-e m1) (+ (* m1a m2e) (* m1c m2f) m1e))
(set! (.-f m1) (+ (* m1b m2e) (* m1d m2f) m1f))
m1]
:clj [(Matrix.
(+ (* m1a m2a) (* m1c m2b))
(+ (* m1b m2a) (* m1d m2b))
(+ (* m1a m2c) (* m1c m2d))
(+ (* m1b m2c) (* m1d m2d))
(+ (* m1a m2e) (* m1c m2f) m1e)
(+ (* m1b m2e) (* m1d m2f) m1f))])))
(reduce multiply! (multiply m1 m2) others)))
(defn add-translate
"Given two TRANSLATE matrixes (only e and f have significative
values), combine them. Quicker than multiplying them, for this
precise case."
([{m1e :e m1f :f} {m2e :e m2f :f}]
(Matrix. 1 0 0 1 (+ m1e m2e) (+ m1f m2f)))
([^Matrix m1 ^Matrix m2]
(let [m1e (dm/get-prop m1 :e)
m1f (dm/get-prop m1 :f)
m2e (dm/get-prop m2 :e)
m2f (dm/get-prop m2 :f)]
(pos->Matrix 1 0 0 1 (+ m1e m2e) (+ m1f m2f))))
([m1 m2 & others]
(reduce add-translate (add-translate m1 m2) others)))
;; FIXME: optimize?
(defn substract
[{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f}
{m2a :a m2b :b m2c :c m2d :d m2e :e m2f :f}]
(Matrix.
(pos->Matrix
(- m1a m2a) (- m1b m2b) (- m1c m2c)
(- m1d m2d) (- m1e m2e) (- m1f m2f)))
@ -221,13 +235,24 @@
(defn translate-matrix
([pt]
(assert (gpt/point? pt))
(Matrix. 1 0 0 1
(dm/get-prop pt :x)
(dm/get-prop pt :y)))
(dm/assert! (gpt/point? pt))
(pos->Matrix 1 0 0 1
(dm/get-prop pt :x)
(dm/get-prop pt :y)))
([x y]
(Matrix. 1 0 0 1 x y)))
(pos->Matrix 1 0 0 1 x y)))
(defn translate-matrix-neg
([pt]
(dm/assert! (gpt/point? pt))
(pos->Matrix 1 0 0 1
(- (dm/get-prop pt :x))
(- (dm/get-prop pt :y))))
([x y]
(pos->Matrix 1 0 0 1 (- x) (- y))))
(defn scale-matrix
([pt center]
@ -235,10 +260,10 @@
sy (dm/get-prop pt :y)
cx (dm/get-prop center :x)
cy (dm/get-prop center :y)]
(Matrix. sx 0 0 sy (- cx (* cx sx)) (- cy (* cy sy)))))
(pos->Matrix sx 0 0 sy (- cx (* cx sx)) (- cy (* cy sy)))))
([pt]
(assert (gpt/point? pt))
(Matrix. (dm/get-prop pt :x) 0 0 (dm/get-prop pt :y) 0 0)))
(dm/assert! (gpt/point? pt))
(pos->Matrix (dm/get-prop pt :x) 0 0 (dm/get-prop pt :y) 0 0)))
(defn rotate-matrix
([angle point]
@ -252,15 +277,15 @@
ns (- s)
tx (+ (* c nx) (* ns ny) cx)
ty (+ (* s nx) (* c ny) cy)]
(Matrix. c s ns c tx ty)))
(pos->Matrix c s ns c tx ty)))
([angle]
(let [a (mth/radians angle)]
(Matrix. (mth/cos a)
(mth/sin a)
(- (mth/sin a))
(mth/cos a)
0
0))))
(pos->Matrix (mth/cos a)
(mth/sin a)
(- (mth/sin a))
(mth/cos a)
0
0))))
(defn skew-matrix
([angle-x angle-y point]
@ -270,7 +295,7 @@
([angle-x angle-y]
(let [m1 (mth/tan (mth/radians angle-x))
m2 (mth/tan (mth/radians angle-y))]
(Matrix. 1 m2 m1 1 0 0))))
(pos->Matrix 1 m2 m1 1 0 0))))
(defn rotate
"Apply rotation transformation to the matrix."
@ -331,6 +356,7 @@
(translate (gpt/negate pt)))
mtx))
;; FIXME: performance
(defn determinant
"Determinant for the affinity transform"
[{:keys [a b c d _ _]}]
@ -340,14 +366,14 @@
"Gets the inverse of the affinity transform `mtx`"
[{:keys [a b c d e f] :as mtx}]
(let [det (determinant mtx)]
(when-not (mth/almost-zero? det)
(when-not ^boolean (mth/almost-zero? det)
(let [a' (/ d det)
b' (/ (- b) det)
c' (/ (- c) det)
d' (/ a det)
e' (/ (- (* c f) (* d e)) det)
f' (/ (- (* b e) (* a f)) det)]
(Matrix. a' b' c' d' e' f')))))
(pos->Matrix a' b' c' d' e' f')))))
(defn round
[mtx]
@ -371,8 +397,41 @@
point))
(defn move?
[{:keys [a b c d _ _]}]
(and (mth/almost-zero? (- a 1))
(mth/almost-zero? b)
(mth/almost-zero? c)
(mth/almost-zero? (- d 1))))
[m]
(and ^boolean (mth/almost-zero? (- (dm/get-prop m :a) 1))
^boolean (mth/almost-zero? (dm/get-prop m :b))
^boolean (mth/almost-zero? (dm/get-prop m :c))
^boolean (mth/almost-zero? (- (dm/get-prop m :d) 1))))
#?(:clj
(fres/add-handlers!
{:name "penpot/matrix"
:class Matrix
:wfn (fn [n w o]
(fres/write-tag! w n 1)
(fres/write-list! w (List/of (.-a ^Matrix o)
(.-b ^Matrix o)
(.-c ^Matrix o)
(.-d ^Matrix o)
(.-e ^Matrix o)
(.-f ^Matrix o))))
:rfn (fn [rdr]
(let [^List x (fres/read-object! rdr)]
(pos->Matrix (.get x 0)
(.get x 1)
(.get x 2)
(.get x 3)
(.get x 4)
(.get x 5))))}))
(t/add-handlers!
{:id "matrix"
:class Matrix
:wfn #(into {} %)
:rfn (fn [m]
(pos->Matrix (get m :a)
(get m :b)
(get m :c)
(get m :d)
(get m :e)
(get m :f)))})

188
common/src/app/common/geom/point.cljc
View File

@ -11,20 +11,26 @@
:clj [clojure.pprint :as pp])
#?(:cljs [cljs.core :as c]
:clj [clojure.core :as c])
#?(:clj [app.common.fressian :as fres])
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.math :as mth]
[app.common.record :as cr]
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
[app.common.schema.openapi :as-alias oapi]
[app.common.spec :as us]
[app.common.transit :as t]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]))
[cuerdas.core :as str])
#?(:clj
(:import
java.util.List)))
;; --- Point Impl
(defrecord Point [x y])
(cr/defrecord Point [x y])
(defn s
[pt]
@ -57,7 +63,7 @@
(map->Point p)
(if (string? p)
(let [[x y] (->> (str/split p #",") (mapv parse-double))]
(Point. x y))
(pos->Point x y))
p)))
(encode [p]
@ -71,7 +77,7 @@
:description "Point"
:error/message "expected a valid point"
:gen/gen (->> (sg/tuple (sg/small-int) (sg/small-int))
(sg/fmap #(apply ->Point %)))
(sg/fmap #(apply pos->Point %)))
::oapi/type "string"
::oapi/format "point"
::oapi/decode decode
@ -85,7 +91,7 @@
(defn point
"Create a Point instance."
([] (Point. 0 0))
([] (pos->Point 0 0))
([v]
(cond
(point? v)
@ -95,12 +101,12 @@
(point v v)
(point-like? v)
(Point. (:x v) (:y v))
(pos->Point (:x v) (:y v))
:else
(ex/raise :hint "invalid arguments (on pointer constructor)" :value v)))
([x y]
(Point. x y)))
(pos->Point x y)))
(defn close?
[p1 p2]
@ -119,25 +125,29 @@
"Returns the addition of the supplied value to both
coordinates of the point as a new point."
[p1 p2]
(assert (and (point? p1)
(point? p2))
"arguments should be pointer instance")
(Point. (+ (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(+ (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))
(dm/assert!
"arguments should be point instance"
(and (point? p1)
(point? p2)))
(pos->Point (+ (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(+ (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))
(defn subtract
"Returns the subtraction of the supplied value to both
coordinates of the point as a new point."
[p1 p2]
(assert (and (point? p1)
(point? p2))
"arguments should be pointer instance")
(Point. (- (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(- (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))
(dm/assert!
"arguments should be pointer instance"
(and (point? p1)
(point? p2)))
(pos->Point (- (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(- (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))
(defn multiply
"Returns the subtraction of the supplied value to both
@ -146,20 +156,20 @@
(assert (and (point? p1)
(point? p2))
"arguments should be pointer instance")
(Point. (* (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(* (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))
(pos->Point (* (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(* (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))
(defn divide
[p1 p2]
(assert (and (point? p1)
(point? p2))
"arguments should be pointer instance")
(Point. (/ (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(/ (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))
(pos->Point (/ (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(/ (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))
(defn min
([] nil)
@ -168,10 +178,10 @@
(cond
(nil? p1) p2
(nil? p2) p1
:else (Point. (c/min (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(c/min (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))))
:else (pos->Point (c/min (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(c/min (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))))
(defn max
([] nil)
([p1] p1)
@ -179,21 +189,21 @@
(cond
(nil? p1) p2
(nil? p2) p1
:else (Point. (c/max (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(c/max (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))))
:else (pos->Point (c/max (dm/get-prop p1 :x)
(dm/get-prop p2 :x))
(c/max (dm/get-prop p1 :y)
(dm/get-prop p2 :y))))))
(defn inverse
[pt]
(assert (point? pt) "point instance expected")
(Point. (/ 1.0 (dm/get-prop pt :x))
(/ 1.0 (dm/get-prop pt :y))))
(pos->Point (/ 1.0 (dm/get-prop pt :x))
(/ 1.0 (dm/get-prop pt :y))))
(defn negate
[pt]
(assert (point? pt) "point instance expected")
(Point. (- (dm/get-prop pt :x))
(- (dm/get-prop pt :y))))
(pos->Point (- (dm/get-prop pt :x))
(- (dm/get-prop pt :y))))
(defn distance
"Calculate the distance between two points."
@ -217,8 +227,8 @@
(dm/get-prop p2 :x))
dy (- (dm/get-prop p1 :y)
(dm/get-prop p2 :y))]
(Point. (mth/abs dx)
(mth/abs dy))))
(pos->Point (mth/abs dx)
(mth/abs dy))))
(defn length
[pt]
@ -285,8 +295,8 @@
(assert (number? angle) "expected number")
(let [len (length p)
angle (mth/radians angle)]
(Point. (* (mth/cos angle) len)
(* (mth/sin angle) len))))
(pos->Point (* (mth/cos angle) len)
(* (mth/sin angle) len))))
(defn quadrant
"Return the quadrant of the angle of the point."
@ -306,22 +316,21 @@
([pt decimals]
(assert (point? pt) "expected point instance")
(assert (number? decimals) "expected number instance")
(Point. (mth/precision (dm/get-prop pt :x) decimals)
(mth/precision (dm/get-prop pt :y) decimals))))
(pos->Point (mth/precision (dm/get-prop pt :x) decimals)
(mth/precision (dm/get-prop pt :y) decimals))))
(defn round-step
"Round the coordinates to the closest half-point"
[pt step]
(assert (point? pt) "expected point instance")
(Point. (mth/round (dm/get-prop pt :x) step)
(mth/round (dm/get-prop pt :y) step)))
(pos->Point (mth/round (dm/get-prop pt :x) step)
(mth/round (dm/get-prop pt :y) step)))
(defn transform
"Transform a point applying a matrix transformation."
[p m]
(when (point? p)
(if (nil? m)
p
(if (some? m)
(let [x (dm/get-prop p :x)
y (dm/get-prop p :y)
a (dm/get-prop m :a)
@ -330,18 +339,51 @@
d (dm/get-prop m :d)
e (dm/get-prop m :e)
f (dm/get-prop m :f)]
(Point. (+ (* x a) (* y c) e)
(+ (* x b) (* y d) f))))))
(pos->Point (+ (* x a) (* y c) e)
(+ (* x b) (* y d) f)))
p)))
(defn transform!
[p m]
(dm/assert!
"expected valid rect and matrix instances"
(and (some? p) (some? m)))
(let [x (dm/get-prop p :x)
y (dm/get-prop p :y)
a (dm/get-prop m :a)
b (dm/get-prop m :b)
c (dm/get-prop m :c)
d (dm/get-prop m :d)
e (dm/get-prop m :e)
f (dm/get-prop m :f)]
#?(:clj
(pos->Point (+ (* x a) (* y c) e)
(+ (* x b) (* y d) f))
:cljs
(do
(set! (.-x p) (+ (* x a) (* y c) e))
(set! (.-y p) (+ (* x b) (* y d) f))
p))))
(defn matrix->point
"Returns a result of transform an identity point with the provided
matrix instance"
[m]
(let [e (dm/get-prop m :e)
f (dm/get-prop m :f)]
(pos->Point e f)))
;; Vector functions
(defn to-vec [p1 p2]
(subtract p2 p1))
(defn scale
[p scalar]
(Point. (* (dm/get-prop p :x) scalar)
(* (dm/get-prop p :y) scalar)))
(pos->Point (* (dm/get-prop p :x) scalar)
(* (dm/get-prop p :y) scalar)))
(defn dot
[p1 p2]
@ -354,14 +396,14 @@
[p1]
(let [p-length (length p1)]
(if (mth/almost-zero? p-length)
(Point. 0 0)
(Point. (/ (dm/get-prop p1 :x) p-length)
(/ (dm/get-prop p1 :y) p-length)))))
(pos->Point 0 0)
(pos->Point (/ (dm/get-prop p1 :x) p-length)
(/ (dm/get-prop p1 :y) p-length)))))
(defn perpendicular
[pt]
(Point. (- (dm/get-prop pt :y))
(dm/get-prop pt :x)))
(pos->Point (- (dm/get-prop pt :y))
(dm/get-prop pt :x)))
(defn project
"V1 perpendicular projection on vector V2"
@ -412,7 +454,7 @@
[p1 p2 t]
(let [x (mth/lerp (dm/get-prop p1 :x) (dm/get-prop p2 :x) t)
y (mth/lerp (dm/get-prop p1 :y) (dm/get-prop p2 :y) t)]
(Point. x y)))
(pos->Point x y)))
(defn rotate
"Rotates the point around center with an angle"
@ -434,7 +476,7 @@
y (+ (* sa (- px cx))
(* ca (- py cy))
cy)]
(Point. x y)))
(pos->Point x y)))
(defn scale-from
"Moves a point in the vector that creates with center with a scale
@ -450,10 +492,10 @@
[p]
(let [x (dm/get-prop p :x)
y (dm/get-prop p :y)]
(Point. (if (mth/almost-zero? x) 0.001 x)
(if (mth/almost-zero? y) 0.001 y))))
(pos->Point (if (mth/almost-zero? x) 0.001 x)
(if (mth/almost-zero? y) 0.001 y))))
;; FIXME: perfromance
(defn abs
[point]
(-> point
@ -464,3 +506,19 @@
(defmethod pp/simple-dispatch Point [obj] (pr obj))
#?(:clj
(fres/add-handlers!
{:name "penpot/point"
:class Point
:wfn (fn [n w ^Point o]
(fres/write-tag! w n 1)
(fres/write-list! w (List/of (.-x o) (.-y o))))
:rfn (fn [rdr]
(let [^List x (fres/read-object! rdr)]
(pos->Point (.get x 0) (.get x 1))))}))
(t/add-handlers!
{:id "point"
:class Point
:wfn #(into {} %)
:rfn map->Point})

355
common/src/app/common/geom/rect.cljc Normal file
View File

@ -0,0 +1,355 @@
;; 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) KALEIDOS INC
(ns app.common.geom.rect
(:require
#?(:clj [app.common.fressian :as fres])
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.math :as mth]
[app.common.record :as rc]
[app.common.transit :as t]))
(rc/defrecord Rect [x y width height x1 y1 x2 y2])
(defn rect?
[o]
(instance? Rect o))
#?(:clj
(fres/add-handlers!
{:name "penpot/geom/rect"
:class Rect
:wfn fres/write-map-like
:rfn (comp map->Rect fres/read-map-like)}))
(t/add-handlers!
{:id "rect"
:class Rect
:wfn #(into {} %)
:rfn map->Rect})
(defn make-rect
([] (make-rect 0 0 0.01 0.01))
([data]
(if (rect? data)
data
(let [{:keys [x y width height]} data]
(make-rect (d/nilv x 0)
(d/nilv y 0)
(d/nilv width 0.01)
(d/nilv height 0.01)))))
([p1 p2]
(dm/assert!
"expected `p1` and `p2` to be points"
(and (gpt/point? p1)
(gpt/point? p2)))
(let [xp1 (dm/get-prop p1 :x)
yp1 (dm/get-prop p1 :y)
xp2 (dm/get-prop p2 :x)
yp2 (dm/get-prop p2 :y)
x1 (mth/min xp1 xp2)
y1 (mth/min yp1 yp2)
x2 (mth/max xp1 xp2)
y2 (mth/max yp1 yp2)]
(make-rect x1 y1 (- x2 x1) (- y2 y1))))
([x y width height]
(when (d/num? x y width height)
(let [w (mth/max width 0.01)
h (mth/max height 0.01)]
(pos->Rect x y w h x y (+ x w) (+ y h))))))
(def empty-rect
(make-rect 0 0 0.01 0.01))
(defn update-rect
[rect type]
(case type
:size
(let [x (dm/get-prop rect :x)
y (dm/get-prop rect :y)
w (dm/get-prop rect :width)
h (dm/get-prop rect :height)]
(assoc rect
:x2 (+ x w)
:y2 (+ y h)))
:corners
(let [x1 (dm/get-prop rect :x1)
y1 (dm/get-prop rect :y1)
x2 (dm/get-prop rect :x2)
y2 (dm/get-prop rect :y2)]
(assoc rect
:x (mth/min x1 x2)
:y (mth/min y1 y2)
:width (mth/abs (- x2 x1))
:height (mth/abs (- y2 y1))))
:position
(let [x (dm/get-prop rect :x)
y (dm/get-prop rect :y)
w (dm/get-prop rect :width)
h (dm/get-prop rect :height)]
(assoc rect
:x1 x
:y1 y
:x2 (+ x w)
:y2 (+ y h)))))
(defn update-rect!
[rect type]
(case type
(:size :position)
(let [x (dm/get-prop rect :x)
y (dm/get-prop rect :y)
w (dm/get-prop rect :width)
h (dm/get-prop rect :height)]
(rc/assoc! rect
:x1 x
:y1 y
:x2 (+ x w)
:y2 (+ y h)))
:corners
(let [x1 (dm/get-prop rect :x1)
y1 (dm/get-prop rect :y1)
x2 (dm/get-prop rect :x2)
y2 (dm/get-prop rect :y2)]
(rc/assoc! rect
:x (mth/min x1 x2)
:y (mth/min y1 y2)
:width (mth/abs (- x2 x1))
:height (mth/abs (- y2 y1))))))
(defn close-rect?
[rect1 rect2]
(dm/assert!
"expected two rects"
(and (rect? rect1)
(rect? rect2)))
(and ^boolean (mth/close? (dm/get-prop rect1 :x)
(dm/get-prop rect2 :x))
^boolean (mth/close? (dm/get-prop rect1 :y)
(dm/get-prop rect2 :y))
^boolean (mth/close? (dm/get-prop rect1 :width)
(dm/get-prop rect2 :width))
^boolean (mth/close? (dm/get-prop rect1 :height)
(dm/get-prop rect2 :height))))
(defn rect->points
[rect]
(dm/assert!
"expected rect instance"
(rect? rect))
(let [x (dm/get-prop rect :x)
y (dm/get-prop rect :y)
w (dm/get-prop rect :width)
h (dm/get-prop rect :height)]
(when (d/num? x y)
(let [w (mth/max w 0.01)
h (mth/max h 0.01)]
[(gpt/point x y)
(gpt/point (+ x w) y)
(gpt/point (+ x w) (+ y h))
(gpt/point x (+ y h))]))))
(defn rect->point
"Extract the position part of the rect"
[rect]
(gpt/point (dm/get-prop rect :x)
(dm/get-prop rect :y)))
(defn rect->center
[rect]
(dm/assert! (rect? rect))
(let [x (dm/get-prop rect :x)
y (dm/get-prop rect :y)
w (dm/get-prop rect :width)
h (dm/get-prop rect :height)]
(when (d/num? x y w h)
(gpt/point (+ x (/ w 2.0))
(+ y (/ h 2.0))))))
(defn rect->lines
[rect]
(dm/assert! (rect? rect))
(let [x (dm/get-prop rect :x)
y (dm/get-prop rect :y)
w (dm/get-prop rect :width)
h (dm/get-prop rect :height)]
(when (d/num? x y)
(let [w (mth/max w 0.01)
h (mth/max h 0.01)]
[[(gpt/point x y) (gpt/point (+ x w) y)]
[(gpt/point (+ x w) y) (gpt/point (+ x w) (+ y h))]
[(gpt/point (+ x w) (+ y h)) (gpt/point x (+ y h))]
[(gpt/point x (+ y h)) (gpt/point x y)]]))))
(defn points->rect
[points]
(when-let [points (seq points)]
(loop [minx ##Inf
miny ##Inf
maxx ##-Inf
maxy ##-Inf
pts points]
(if-let [pt (first pts)]
(let [x (dm/get-prop pt :x)
y (dm/get-prop pt :y)]
(recur (mth/min minx x)
(mth/min miny y)
(mth/max maxx x)
(mth/max maxy y)
(rest pts)))
(when (d/num? minx miny maxx maxy)
(make-rect minx miny (- maxx minx) (- maxy miny)))))))
;; FIXME: measure performance
(defn bounds->rect
[[pa pb pc pd]]
(let [ax (dm/get-prop pa :x)
ay (dm/get-prop pa :y)
bx (dm/get-prop pb :x)
by (dm/get-prop pb :y)
cx (dm/get-prop pc :x)
cy (dm/get-prop pc :y)
dx (dm/get-prop pd :x)
dy (dm/get-prop pd :y)
minx (mth/min ax bx cx dx)
miny (mth/min ay by cy dy)
maxx (mth/max ax bx cx dx)
maxy (mth/max ay by cy dy)]
(when (d/num? minx miny maxx maxy)
(make-rect minx miny (- maxx minx) (- maxy miny)))))
(def ^:private xf-keep-x (keep #(dm/get-prop % :x)))
(def ^:private xf-keep-y (keep #(dm/get-prop % :y)))
(def ^:private xf-keep-x2 (keep #(dm/get-prop % :x2)))
(def ^:private xf-keep-y2 (keep #(dm/get-prop % :y2)))
(defn squared-points
[points]
(when (d/not-empty? points)
(let [minx (transduce xf-keep-x d/min ##Inf points)
miny (transduce xf-keep-y d/min ##Inf points)
maxx (transduce xf-keep-x2 d/max ##-Inf points)
maxy (transduce xf-keep-y2 d/max ##-Inf points)]
(when (d/num? minx miny maxx maxy)
[(gpt/point minx miny)
(gpt/point maxx miny)
(gpt/point maxx maxy)
(gpt/point minx maxy)]))))
(defn join-rects [rects]
(when (seq rects)
(let [minx (transduce xf-keep-x d/min ##Inf rects)
miny (transduce xf-keep-y d/min ##Inf rects)
maxx (transduce xf-keep-x2 d/max ##-Inf rects)
maxy (transduce xf-keep-y2 d/max ##-Inf rects)]
(when (d/num? minx miny maxx maxy)
(make-rect minx miny (- maxx minx) (- maxy miny))))))
(defn center->rect
[point w h]
(when (some? point)
(let [x (dm/get-prop point :x)
y (dm/get-prop point :y)]
(when (d/num? x y w h)
(make-rect (- x (/ w 2))
(- y (/ h 2))
w
h)))))
(defn s=
[a b]
(mth/almost-zero? (- a b)))
;; FIXME: performance
(defn overlaps-rects?
"Check for two rects to overlap. Rects won't overlap only if
one of them is fully to the left or the top"
[rect-a rect-b]
(let [x1a (:x rect-a)
y1a (:y rect-a)
x2a (+ (:x rect-a) (:width rect-a))
y2a (+ (:y rect-a) (:height rect-a))
x1b (:x rect-b)
y1b (:y rect-b)
x2b (+ (:x rect-b) (:width rect-b))
y2b (+ (:y rect-b) (:height rect-b))]
(and (or (> x2a x1b) (s= x2a x1b))
(or (>= x2b x1a) (s= x2b x1a))
(or (<= y1b y2a) (s= y1b y2a))
(or (<= y1a y2b) (s= y1a y2b)))))
(defn contains-point?
[rect point]
(assert (gpt/point? point))
(let [x1 (:x rect)
y1 (:y rect)
x2 (+ (:x rect) (:width rect))
y2 (+ (:y rect) (:height rect))
px (:x point)
py (:y point)]
(and (or (> px x1) (s= px x1))
(or (< px x2) (s= px x2))
(or (> py y1) (s= py y1))
(or (< py y2) (s= py y2)))))
(defn contains-rect?
"Check if a rect srb is contained inside sra"
[sra srb]
(let [ax1 (dm/get-prop sra :x1)
ax2 (dm/get-prop sra :x2)
ay1 (dm/get-prop sra :y1)
ay2 (dm/get-prop sra :y2)
bx1 (dm/get-prop srb :x1)
bx2 (dm/get-prop srb :x2)
by1 (dm/get-prop srb :y1)
by2 (dm/get-prop srb :y2)]
(and (>= bx1 ax1)
(<= bx2 ax2)
(>= by1 ay1)
(<= by2 ay2))))
(defn corners->rect
([p1 p2]
(corners->rect (:x p1) (:y p1) (:x p2) (:y p2)))
([xp1 yp1 xp2 yp2]
(make-rect (mth/min xp1 xp2)
(mth/min yp1 yp2)
(abs (- xp1 xp2))
(abs (- yp1 yp2)))))
(defn clip-rect
[selrect bounds]
(when (rect? selrect)
(dm/assert! (rect? bounds))
(let [x1 (dm/get-prop selrect :x1)
y1 (dm/get-prop selrect :y1)
x2 (dm/get-prop selrect :x2)
y2 (dm/get-prop selrect :y2)
bx1 (dm/get-prop bounds :x1)
by1 (dm/get-prop bounds :y1)
bx2 (dm/get-prop bounds :x2)
by2 (dm/get-prop bounds :y2)]
(corners->rect (mth/max bx1 x1)
(mth/max by1 y1)
(mth/min bx2 x2)
(mth/min by2 y2)))))

98
common/src/app/common/geom/shapes.cljc
View File

@ -9,6 +9,7 @@
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes.bool :as gsb]
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.constraints :as gct]
@ -16,28 +17,30 @@
[app.common.geom.shapes.intersect :as gsi]
[app.common.geom.shapes.modifiers :as gsm]
[app.common.geom.shapes.path :as gsp]
[app.common.geom.shapes.rect :as gpr]
[app.common.geom.shapes.text :as gst]
[app.common.geom.shapes.transforms :as gtr]
[app.common.math :as mth]))
;; --- Outer Rect
(defn selection-rect
"Returns a rect that contains all the shapes and is aware of the
rotation of each shape. Mainly used for multiple selection."
[shapes]
(->> shapes
(map (comp gpr/points->selrect :points))
(gpr/join-selrects)))
(defn translate-to-frame
[shape {:keys [x y]}]
(gtr/move shape (gpt/negate (gpt/point x y))) )
[shape frame]
(->> (gpt/point (- (dm/get-prop frame :x))
(- (dm/get-prop frame :y)))
(gtr/move shape)))
(defn translate-from-frame
[shape {:keys [x y]}]
(gtr/move shape (gpt/point x y)) )
[shape frame]
(gtr/move shape (gpt/point (dm/get-prop frame :x)
(dm/get-prop frame :y))))
(defn shape->rect
[shape]
(let [x (dm/get-prop shape :x)
y (dm/get-prop shape :y)
w (dm/get-prop shape :width)
h (dm/get-prop shape :height)]
(when (d/num? x y w h)
(grc/make-rect x y w h))))
;; --- Helpers
@ -45,7 +48,7 @@
"Returns a rect that wraps the shape after all transformations applied."
[shape]
;; TODO: perhaps we need to store this calculation in a shape attribute
(gpr/points->rect (:points shape)))
(grc/points->rect (:points shape)))
(defn left-bound
"Returns the lowest x coord of the shape BEFORE applying transformations."
@ -82,21 +85,38 @@
(update :width (comp inc inc))
(update :height (comp inc inc))))))
(defn selrect->areas [bounds selrect]
(let [{bound-x1 :x1 bound-x2 :x2 bound-y1 :y1 bound-y2 :y2} bounds
{sr-x1 :x1 sr-x2 :x2 sr-y1 :y1 sr-y2 :y2} selrect]
{:left (gpr/corners->selrect bound-x1 sr-y1 sr-x1 sr-y2)
:top (gpr/corners->selrect sr-x1 bound-y1 sr-x2 sr-y1)
:right (gpr/corners->selrect sr-x2 sr-y1 bound-x2 sr-y2)
:bottom (gpr/corners->selrect sr-x1 sr-y2 sr-x2 bound-y2)}))
(defn get-areas
[bounds selrect]
(let [bound-x1 (dm/get-prop bounds :x1)
bound-x2 (dm/get-prop bounds :x2)
bound-y1 (dm/get-prop bounds :y1)
bound-y2 (dm/get-prop bounds :y2)
sr-x1 (dm/get-prop selrect :x1)
sr-x2 (dm/get-prop selrect :x2)
sr-y1 (dm/get-prop selrect :y1)
sr-y2 (dm/get-prop selrect :y2)]
{:left (grc/corners->rect bound-x1 sr-y1 sr-x1 sr-y2)
:top (grc/corners->rect sr-x1 bound-y1 sr-x2 sr-y1)
:right (grc/corners->rect sr-x2 sr-y1 bound-x2 sr-y2)
:bottom (grc/corners->rect sr-x1 sr-y2 sr-x2 bound-y2)}))
(defn distance-selrect [selrect other]
(let [{:keys [x1 y1]} other
{:keys [x2 y2]} selrect]
(defn distance-selrect
[selrect other]
(dm/assert!
(and (grc/rect? selrect)
(grc/rect? other)))
(let [x1 (dm/get-prop other :x1)
y1 (dm/get-prop other :y1)
x2 (dm/get-prop selrect :x2)
y2 (dm/get-prop selrect :y2)]
(gpt/point (- x1 x2) (- y1 y2))))
(defn distance-shapes [shape other]
(distance-selrect (:selrect shape) (:selrect other)))
(distance-selrect
(dm/get-prop shape :selrect)
(dm/get-prop other :selrect)))
(defn close-attrs?
"Compares two shapes attributes to see if they are equal or almost
@ -131,27 +151,11 @@
(= val1 val2)))))
;; EXPORTS
(dm/export gco/center-shape)
(dm/export gco/center-selrect)
(dm/export gco/center-rect)
(dm/export gco/center-points)
(dm/export gco/shape->center)
(dm/export gco/shapes->rect)
(dm/export gco/points->center)
(dm/export gco/transform-points)
(dm/export gpr/make-rect)
(dm/export gpr/make-selrect)
(dm/export gpr/rect->selrect)
(dm/export gpr/rect->points)
(dm/export gpr/points->selrect)
(dm/export gpr/points->rect)
(dm/export gpr/center->rect)
(dm/export gpr/center->selrect)
(dm/export gpr/join-rects)
(dm/export gpr/join-selrects)
(dm/export gpr/contains-selrect?)
(dm/export gpr/contains-point?)
(dm/export gpr/close-selrect?)
(dm/export gpr/clip-selrect)
(dm/export gtr/move)
(dm/export gtr/absolute-move)
(dm/export gtr/transform-matrix)
@ -173,6 +177,7 @@
(dm/export gct/calc-child-modifiers)
;; PATHS
;; FIXME: rename
(dm/export gsp/content->selrect)
(dm/export gsp/transform-content)
(dm/export gsp/open-path?)
@ -196,6 +201,3 @@
;; Modifiers
(dm/export gsm/set-objects-modifiers)
;; Text
(dm/export gst/position-data-selrect)

182
common/src/app/common/geom/shapes/bounds.cljc
View File

@ -7,32 +7,29 @@
(ns app.common.geom.shapes.bounds
(:require
[app.common.data :as d]
[app.common.geom.shapes.rect :as gsr]
[app.common.data.macros :as dm]
[app.common.geom.rect :as grc]
[app.common.math :as mth]
[app.common.pages.helpers :as cph]))
(defn shape-stroke-margin
[shape stroke-width]
(if (= (:type shape) :path)
(if (cph/path-shape? shape)
;; TODO: Calculate with the stroke offset (not implemented yet
(mth/sqrt (* 2 stroke-width stroke-width))
(- (mth/sqrt (* 2 stroke-width stroke-width)) stroke-width)))
(defn blur-filters [type value]
(->> [value]
(remove :hidden)
(filter #(= (:type %) type))
(map #(hash-map :id (str "filter_" (:id %))
:type (:type %)
:params %))))
(defn shadow-filters [type filters]
(->> filters
(remove :hidden)
(filter #(= (:style %) type))
(map #(hash-map :id (str "filter_" (:id %))
:type (:style %)
:params %))))
(defn- apply-filters
[type filters]
(sequence
(comp
(remove :hidden)
(filter #(= (:style %) type))
(map (fn [item]
{:id (dm/str "filter_" (:id item))
:type type
:params item})))
filters))
(defn shape->filters
[shape]
@ -41,93 +38,112 @@
;; Background blur won't work in current SVG specification
;; We can revisit this in the future
#_(->> shape :blur (blur-filters :background-blur))
#_(->> shape :blur (into []) (blur-filters :background-blur))
(->> shape :shadow (shadow-filters :drop-shadow))
(->> shape :shadow (apply-filters :drop-shadow))
[{:id "shape" :type :blend-filters}]
(->> shape :shadow (shadow-filters :inner-shadow))
(->> shape :blur (blur-filters :layer-blur))))
(->> shape :shadow (apply-filters :inner-shadow))
(->> shape :blur (into []) (apply-filters :layer-blur))))
(defn calculate-filter-bounds [{:keys [x y width height]} filter-entry]
(let [{:keys [offset-x offset-y blur spread] :or {offset-x 0 offset-y 0 blur 0 spread 0}} (:params filter-entry)
filter-x (min x (+ x offset-x (- spread) (- blur) -5))
filter-y (min y (+ y offset-y (- spread) (- blur) -5))
filter-width (+ width (mth/abs offset-x) (* spread 2) (* blur 2) 10)
filter-height (+ height (mth/abs offset-y) (* spread 2) (* blur 2) 10)]
(gsr/make-selrect filter-x filter-y filter-width filter-height)))
(defn- calculate-filter-bounds
[selrect filter-entry]
(let [x (dm/get-prop selrect :x)
y (dm/get-prop selrect :y)
w (dm/get-prop selrect :width)
h (dm/get-prop selrect :height)
{:keys [offset-x offset-y blur spread]
:or {offset-x 0 offset-y 0 blur 0 spread 0}}
(:params filter-entry)
filter-x (mth/min x (+ x offset-x (- spread) (- blur) -5))
filter-y (mth/min y (+ y offset-y (- spread) (- blur) -5))
filter-w (+ w (mth/abs offset-x) (* spread 2) (* blur 2) 10)
filter-h (+ h (mth/abs offset-y) (* spread 2) (* blur 2) 10)]
(grc/make-rect filter-x filter-y filter-w filter-h)))
(defn get-rect-filter-bounds
[selrect filters blur-value]
(let [filter-bounds (->> filters
(filter #(= :drop-shadow (:type %)))
(map (partial calculate-filter-bounds selrect))
(concat [selrect])
(gsr/join-selrects))
delta-blur (* blur-value 2)
result
(-> filter-bounds
(update :x - delta-blur)
(update :y - delta-blur)
(update :x1 - delta-blur)
(update :y1 - delta-blur)
(update :x2 + delta-blur)
(update :y2 + delta-blur)
(update :width + (* delta-blur 2))
(update :height + (* delta-blur 2)))]
result))
(let [bounds-xf (comp
(filter #(= :drop-shadow (:type %)))
(map (partial calculate-filter-bounds selrect)))
delta-blur (* blur-value 2)]
(-> (into [selrect] bounds-xf filters)
(grc/join-rects)
(update :x - delta-blur)
(update :y - delta-blur)
(update :x1 - delta-blur)
(update :y1 - delta-blur)
(update :x2 + delta-blur)
(update :y2 + delta-blur)
(update :width + (* delta-blur 2))
(update :height + (* delta-blur 2)))))
(defn get-shape-filter-bounds
([shape]
(let [svg-root? (and (= :svg-raw (:type shape)) (not= :svg (get-in shape [:content :tag])))]
(if svg-root?
(:selrect shape)
(let [filters (shape->filters shape)
blur-value (or (-> shape :blur :value) 0)]
(get-rect-filter-bounds (-> shape :points gsr/points->selrect) filters blur-value))))))
[shape]
(if (and (cph/svg-raw-shape? shape)
(not= :svg (dm/get-in shape [:content :tag])))
(dm/get-prop shape :selrect)
(let [filters (shape->filters shape)
blur-value (or (-> shape :blur :value) 0)
srect (-> (dm/get-prop shape :points)
(grc/points->rect))]
(get-rect-filter-bounds srect filters blur-value))))
(defn calculate-padding
([shape]
(calculate-padding shape false))
([shape ignore-margin?]
(let [stroke-width (apply max 0 (map #(case (:stroke-alignment % :center)
:center (/ (:stroke-width % 0) 2)
:outer (:stroke-width % 0)
0) (:strokes shape)))
(let [strokes (:strokes shape)
margin (if ignore-margin?
0
(apply max 0 (map #(shape-stroke-margin % stroke-width) (:strokes shape))))
stroke-width
(->> strokes
(map #(case (get % :stroke-alignment :center)
:center (/ (:stroke-width % 0) 2)
:outer (:stroke-width % 0)
0))
(reduce d/max 0))
shadow-width (apply max 0 (map #(case (:style % :drop-shadow)
:drop-shadow (+ (mth/abs (:offset-x %)) (* (:spread %) 2) (* (:blur %) 2) 10)
0) (:shadow shape)))
margin
(if ignore-margin?
0
(->> strokes
(map #(shape-stroke-margin % stroke-width))
(reduce d/max 0)))
shadow-height (apply max 0 (map #(case (:style % :drop-shadow)
:drop-shadow (+ (mth/abs (:offset-y %)) (* (:spread %) 2) (* (:blur %) 2) 10)
0) (:shadow shape)))]
shadow-width
(->> (:shadow shape)
(map #(case (:style % :drop-shadow)
:drop-shadow (+ (mth/abs (:offset-x %)) (* (:spread %) 2) (* (:blur %) 2) 10)
0))
(reduce d/max 0))
shadow-height
(->> (:shadow shape)
(map #(case (:style % :drop-shadow)
:drop-shadow (+ (mth/abs (:offset-y %)) (* (:spread %) 2) (* (:blur %) 2) 10)
0))
(reduce d/max 0))]
{:horizontal (+ stroke-width margin shadow-width)
:vertical (+ stroke-width margin shadow-height)})))
(defn- add-padding
[bounds padding]
(-> bounds
(update :x - (:horizontal padding))
(update :x1 - (:horizontal padding))
(update :x2 + (:horizontal padding))
(update :y - (:vertical padding))
(update :y1 - (:vertical padding))
(update :y2 + (:vertical padding))
(update :width + (* 2 (:horizontal padding)))
(update :height + (* 2 (:vertical padding)))))
(let [h-padding (:horizontal padding)
v-padding (:vertical padding)]
(-> bounds
(update :x - h-padding)
(update :x1 - h-padding)
(update :x2 + h-padding)
(update :y - v-padding)
(update :y1 - v-padding)
(update :y2 + v-padding)
(update :width + (* 2 h-padding))
(update :height + (* 2 v-padding)))))
(defn get-object-bounds
[objects shape]
(let [calculate-base-bounds
(fn [shape]
(-> (get-shape-filter-bounds shape)
@ -138,7 +154,7 @@
(empty? (:shapes shape))
[(calculate-base-bounds shape)]
(:masked-group? shape)
(:masked-group shape)
[(calculate-base-bounds shape)]
(and (cph/frame-shape? shape) (not (:show-content shape)))
@ -153,17 +169,15 @@
(:show-content shape))
(or (not (cph/group-shape? shape))
(not (:masked-group? shape)))))
(not (:masked-group shape)))))
(:id shape)
(fn [result child]
(conj result (calculate-base-bounds child)))
[(calculate-base-bounds shape)]))
children-bounds
(cond->> (gsr/join-selrects bounds)
(cond->> (grc/join-rects bounds)
(not (cph/frame-shape? shape)) (or (:children-bounds shape)))
filters (shape->filters shape)

111
common/src/app/common/geom/shapes/common.cljc
View File

@ -7,80 +7,83 @@
(ns app.common.geom.shapes.common
(: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.shapes.rect :as gpr]
[app.common.math :as mth]))
[app.common.geom.rect :as grc]
[app.common.math :as mth]
[app.common.record :as cr]))
(defn center-rect
[{:keys [x y width height]}]
(when (d/num? x y width height)
(gpt/point (+ x (/ width 2.0))
(+ y (/ height 2.0)))))
(def ^:private xf-keep-x (keep #(dm/get-prop % :x)))
(def ^:private xf-keep-y (keep #(dm/get-prop % :y)))
(defn center-selrect
"Calculate the center of the selrect."
[selrect]
(center-rect selrect))
(defn shapes->rect
"Returns a rect that contains all the shapes and is aware of the
rotation of each shape. Mainly used for multiple selection."
[shapes]
(->> shapes
(keep (fn [shape]
(-> (dm/get-prop shape :points)
(grc/points->rect))))
(grc/join-rects)))
(defn center-points [points]
(let [ptx (into [] (keep :x) points)
pty (into [] (keep :y) points)
minx (reduce min ##Inf ptx)
miny (reduce min ##Inf pty)
maxx (reduce max ##-Inf ptx)
maxy (reduce max ##-Inf pty)]
(defn points->center
[points]
(let [ptx (into [] xf-keep-x points)
pty (into [] xf-keep-y points)
minx (reduce d/min ##Inf ptx)
miny (reduce d/min ##Inf pty)
maxx (reduce d/max ##-Inf ptx)
maxy (reduce d/max ##-Inf pty)]
(gpt/point (/ (+ minx maxx) 2.0)
(/ (+ miny maxy) 2.0))))
(defn center-bounds [[a b c d]]
(let [xa (:x a)
ya (:y a)
xb (:x b)
yb (:y b)
xc (:x c)
yc (:y c)
xd (:x d)
yd (:y d)
minx (min xa xb xc xd)
miny (min ya yb yc yd)
maxx (max xa xb xc xd)
maxy (max ya yb yc yd)]
(gpt/point (/ (+ minx maxx) 2.0)
(/ (+ miny maxy) 2.0))))
(defn center-shape
(defn shape->center
"Calculate the center of the shape."
[shape]
(center-rect (:selrect shape)))
(grc/rect->center (dm/get-prop shape :selrect)))
(defn transform-points
([points matrix]
(transform-points points nil matrix))
([points center matrix]
(if (and (d/not-empty? points) (gmt/matrix? matrix))
(let [prev (if center (gmt/translate-matrix center) (gmt/matrix))
post (if center (gmt/translate-matrix (gpt/negate center)) (gmt/matrix))
tr-point (fn [point]
(gpt/transform point (gmt/multiply prev matrix post)))]
(mapv tr-point points))
(if (and ^boolean (gmt/matrix? matrix)
^boolean (seq points))
(let [prev (if (some? center) (gmt/translate-matrix center) (cr/clone gmt/base))
post (if (some? center) (gmt/translate-matrix-neg center) gmt/base)
mtx (-> prev
(gmt/multiply! matrix)
(gmt/multiply! post))]
(mapv #(gpt/transform % mtx) points))
points)))
(defn transform-selrect
[{:keys [x1 y1 x2 y2] :as sr} matrix]
(let [[c1 c2] (transform-points [(gpt/point x1 y1) (gpt/point x2 y2)] matrix)]
(gpr/corners->selrect c1 c2)))
[selrect matrix]
(dm/assert!
"expected valid rect and matrix instances"
(and (grc/rect? selrect)
(gmt/matrix? matrix)))
(let [x1 (dm/get-prop selrect :x1)
y1 (dm/get-prop selrect :y1)
x2 (dm/get-prop selrect :x2)
y2 (dm/get-prop selrect :y2)
p1 (gpt/point x1 y1)
p2 (gpt/point x2 y2)
c1 (gpt/transform! p1 matrix)
c2 (gpt/transform! p2 matrix)]
(grc/corners->rect c1 c2)))
(defn invalid-geometry?
[{:keys [points selrect]}]
(or (mth/nan? (:x selrect))
(mth/nan? (:y selrect))
(mth/nan? (:width selrect))
(mth/nan? (:height selrect))
(some (fn [p]
(or (mth/nan? (:x p))
(mth/nan? (:y p))))
points)))
(or ^boolean (mth/nan? (:x selrect))
^boolean (mth/nan? (:y selrect))
^boolean (mth/nan? (:width selrect))
^boolean (mth/nan? (:height selrect))
^boolean (some (fn [p]
(or ^boolean (mth/nan? (:x p))
^boolean (mth/nan? (:y p))))
points)))

26
common/src/app/common/geom/shapes/constraints.cljc
View File

@ -6,7 +6,9 @@
(ns app.common.geom.shapes.constraints
(:require
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.intersect :as gsi]
[app.common.geom.shapes.points :as gpo]
[app.common.geom.shapes.transforms :as gtr]
@ -204,19 +206,22 @@
disp-start (displacement start-before start-after before-side-vector after-side-vector)
;; We get the current axis side and grow it on both side by the end+start displacements
before-vec (side-vector axis child-points-after)
after-vec (side-vector-resize axis child-points-after disp-start disp-end)
before-vec (side-vector axis child-points-after)
after-vec (side-vector-resize axis child-points-after disp-start disp-end)
;; after-vec will contain the side length of the grown side
;; we scale the shape by the diference and translate it by the start
;; displacement (so its left+top position is constant)
scale (/ (gpt/length after-vec) (max 0.01 (gpt/length before-vec)))
scale (/ (gpt/length after-vec) (mth/max 0.01 (gpt/length before-vec)))
resize-origin (gpo/origin child-points-after)
resize-origin (gpo/origin child-points-after)
[_ transform transform-inverse] (gtr/calculate-geometry parent-points-after)
center (gco/points->center parent-points-after)
selrect (gtr/calculate-selrect parent-points-after center)
transform (gtr/calculate-transform parent-points-after center selrect)
transform-inverse (when (some? transform) (gmt/inverse transform))
resize-vector (get-scale axis scale)]
resize-vector (get-scale axis scale)]
(-> (ctm/empty)
(ctm/resize resize-vector resize-origin transform transform-inverse)
(ctm/move disp-start))))
@ -276,10 +281,13 @@
resize-vector (gpt/point scale-x scale-y)
resize-origin (gpo/origin transformed-child-bounds)
[_ transform transform-inverse] (gtr/calculate-geometry transformed-parent-bounds)]
(-> modifiers
(ctm/resize resize-vector resize-origin transform transform-inverse))))
center (gco/points->center transformed-child-bounds)
selrect (gtr/calculate-selrect transformed-child-bounds center)
transform (gtr/calculate-transform transformed-child-bounds center selrect)
transform-inverse (when (some? transform) (gmt/inverse transform))]
(ctm/resize modifiers resize-vector resize-origin transform transform-inverse)))
(defn calc-child-modifiers
[parent child modifiers ignore-constraints child-bounds parent-bounds transformed-parent-bounds]

24
common/src/app/common/geom/shapes/flex_layout/drop_area.cljc
View File

@ -9,10 +9,10 @@
[app.common.data :as d]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.flex-layout.lines :as fli]
[app.common.geom.shapes.points :as gpo]
[app.common.geom.shapes.rect :as gsr]
[app.common.geom.shapes.transforms :as gtr]
[app.common.pages.helpers :as cph]
[app.common.types.modifiers :as ctm]
@ -59,16 +59,16 @@
(if row?
(let [half-point-width (+ (- box-x x) (/ box-width 2))]
[(gsr/make-rect x y width height)
(-> (gsr/make-rect x y half-point-width height)
[(grc/make-rect x y width height)
(-> (grc/make-rect x y half-point-width height)
(assoc :index (if reverse? (inc index) index)))
(-> (gsr/make-rect (+ x half-point-width) y (- width half-point-width) height)
(-> (grc/make-rect (+ x half-point-width) y (- width half-point-width) height)
(assoc :index (if reverse? index (inc index))))])
(let [half-point-height (+ (- box-y y) (/ box-height 2))]
[(gsr/make-rect x y width height)
(-> (gsr/make-rect x y width half-point-height)
[(grc/make-rect x y width height)
(-> (grc/make-rect x y width half-point-height)
(assoc :index (if reverse? (inc index) index)))
(-> (gsr/make-rect x (+ y half-point-height) width (- height half-point-height))
(-> (grc/make-rect x (+ y half-point-height) width (- height half-point-height))
(assoc :index (if reverse? index (inc index))))]))))
(defn drop-line-area
@ -83,7 +83,7 @@
v-center? (and col? (ctl/v-center? frame))
v-end? (and row? (ctl/v-end? frame))
center (gco/center-shape frame)
center (gco/shape->center frame)
start-p (gmt/transform-point-center start-p center transform-inverse)
line-width
@ -136,7 +136,7 @@
:else
(+ line-height (- box-y prev-y) (/ layout-gap-row 2)))]
(gsr/make-rect x y width height)))
(grc/make-rect x y width height)))
(defn layout-drop-areas
"Retrieve the layout drop areas to move shapes inside layouts"
@ -190,7 +190,7 @@
(-> (ctm/empty)
(ctm/resize (gpt/point (if flip-x -1.0 1.0)
(if flip-y -1.0 1.0))
(gco/center-shape shape)
(gco/shape->center shape)
transform
transform-inverse))]
[(gtr/transform-shape shape modifiers) modifiers])
@ -212,6 +212,6 @@
[frame-id objects position]
(let [frame (get objects frame-id)
drop-areas (get-drop-areas frame objects)
position (gmt/transform-point-center position (gco/center-shape frame) (:transform-inverse frame))
area (d/seek #(gsr/contains-point? % position) drop-areas)]
position (gmt/transform-point-center position (gco/shape->center frame) (:transform-inverse frame))
area (d/seek #(grc/contains-point? % position) drop-areas)]
(:index area)))

14
common/src/app/common/geom/shapes/intersect.cljc
View File

@ -9,9 +9,9 @@
[app.common.data :as d]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.path :as gpp]
[app.common.geom.shapes.rect :as gpr]
[app.common.geom.shapes.text :as gte]
[app.common.math :as mth]))
@ -163,7 +163,7 @@
"Checks if the given rect intersects with the selrect"
[rect points]
(let [rect-points (gpr/rect->points rect)
(let [rect-points (grc/rect->points rect)
rect-lines (points->lines rect-points)
points-lines (points->lines points)]
@ -182,7 +182,7 @@
;; TODO: Look for ways to optimize this operation
simple? (> (count (:content shape)) 100)
rect-points (gpr/rect->points rect)
rect-points (grc/rect->points rect)
rect-lines (points->lines rect-points)
path-lines (if simple?
(points->lines (:points shape))
@ -268,7 +268,7 @@
"Checks if the given rect overlaps with an ellipse"
[shape rect]
(let [rect-points (gpr/rect->points rect)
(let [rect-points (grc/rect->points rect)
rect-lines (points->lines rect-points)
{:keys [x y width height]} shape
@ -289,7 +289,7 @@
[{:keys [position-data] :as shape} rect]
(if (and (some? position-data) (d/not-empty? position-data))
(let [center (gco/center-shape shape)
(let [center (gco/shape->center shape)
transform-rect
(fn [rect-points]
@ -297,7 +297,7 @@
(->> position-data
(map (comp transform-rect
gpr/rect->points
grc/rect->points
gte/position-data->rect))
(some #(overlaps-rect-points? rect %))))
(overlaps-rect-points? rect (:points shape))))
@ -332,7 +332,7 @@
(defn has-point-rect?
[rect point]
(let [lines (gpr/rect->lines rect)]
(let [lines (grc/rect->lines rect)]
(is-point-inside-evenodd? point lines)))
(defn has-point?

84
common/src/app/common/geom/shapes/modifiers.cljc
View File

@ -29,7 +29,7 @@
;; [(get-in objects [k :name]) v]))
;; modif-tree))))
(defn children-sequence
(defn- get-children-seq
"Given an id returns a sequence of its children"
[id objects]
@ -39,61 +39,63 @@
id)
(map #(get objects %))))
(defn resolve-tree-sequence
(defn- resolve-tree
"Given the ids that have changed search for layout roots to recalculate"
[ids objects]
(dm/assert! (or (nil? ids) (set? ids)))
(let [get-tree-root
(fn ;; Finds the tree root for the current id
[id]
(let [;; Finds the tree root for the current id
get-tree-root
(fn [id]
(loop [current id
result id]
(let [shape (get objects current)
parent (get objects (:parent-id shape))]
(cond
(or (not shape) (= uuid/zero current))
(let [shape (get objects current)]
(if (or (not ^boolean shape) (= uuid/zero current))
result
(let [parent-id (dm/get-prop shape :parent-id)
parent (get objects parent-id)]
(cond
;; Frame found, but not layout we return the last layout found (or the id)
(and ^boolean (cph/frame-shape? parent)
(not ^boolean (ctl/any-layout? parent)))
result
;; Frame found, but not layout we return the last layout found (or the id)
(and (= :frame (:type parent))
(not (ctl/any-layout? parent)))
result
;; Layout found. We continue upward but we mark this layout
(ctl/any-layout? parent)
(recur parent-id parent-id)
;; Layout found. We continue upward but we mark this layout
(ctl/any-layout? parent)
(recur (:id parent) (:id parent))
;; If group or boolean or other type of group we continue with the last result
:else
(recur parent-id result)))))))
;; If group or boolean or other type of group we continue with the last result
:else
(recur (:id parent) result)))))
is-child? #(cph/is-child? objects %1 %2)
calculate-common-roots
(fn ;; Given some roots retrieves the minimum number of tree roots
[result id]
;; Given some roots retrieves the minimum number of tree roots
search-common-roots
(fn [result id]
(if (= id uuid/zero)
result
(let [root (get-tree-root id)
;; Remove the children from the current root
result
(if (cph/has-children? objects root)
(into #{} (remove #(is-child? root %)) result)
(if ^boolean (cph/has-children? objects root)
(into #{} (remove (partial cph/is-child? objects root)) result)
result)
root-parents (cph/get-parent-ids objects root)
contains-parent? (some #(contains? result %) root-parents)]
(cond-> result
(not contains-parent?)
(conj root)))))
contains-parent?
(->> (cph/get-parent-ids objects root)
(some (partial contains? result)))]
roots (->> ids (reduce calculate-common-roots #{}))]
(concat
(when (contains? ids uuid/zero) [(get objects uuid/zero)])
(mapcat #(children-sequence % objects) roots))))
(if (not contains-parent?)
(conj result root)
result))))
result
(->> (reduce search-common-roots #{} ids)
(mapcat #(get-children-seq % objects)))]
(if (contains? ids uuid/zero)
(cons (get objects uuid/zero) result)
result)))
(defn- set-children-modifiers
"Propagates the modifiers from a parent too its children applying constraints if necesary"
@ -371,7 +373,7 @@
(defn reflow-layout
[objects old-modif-tree bounds ignore-constraints id]
(let [tree-seq (children-sequence id objects)
(let [tree-seq (get-children-seq id objects)
[modif-tree _]
(reduce
@ -416,7 +418,7 @@
(let [resize-modif-tree {current {:modifiers auto-resize-modifiers}}
tree-seq (children-sequence current objects)
tree-seq (get-children-seq current objects)
[resize-modif-tree _]
(reduce
@ -440,7 +442,7 @@
;; Step-2: After resizing we still need to reflow the layout parents that are not auto-width/height
tree-seq (resolve-tree-sequence to-reflow objects)
tree-seq (resolve-tree to-reflow objects)
[reflow-modif-tree _]
(reduce
@ -476,7 +478,7 @@
(some? old-modif-tree)
(transform-bounds objects old-modif-tree))
shapes-tree (resolve-tree-sequence (-> modif-tree keys set) objects)
shapes-tree (resolve-tree (-> modif-tree keys set) objects)
;; Calculate the input transformation and constraints
modif-tree (reduce #(propagate-modifiers-constraints objects bounds ignore-constraints %1 %2) modif-tree shapes-tree)

43
common/src/app/common/geom/shapes/path.cljc
View File

@ -9,8 +9,8 @@
[app.common.data :as d]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.common :as gsc]
[app.common.geom.shapes.rect :as gpr]
[app.common.geom.rect :as grc]
[app.common.geom.shapes.common :as gco]
[app.common.math :as mth]
[app.common.path.commands :as upc]
[app.common.path.subpaths :as sp]))
@ -46,11 +46,14 @@
(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 [])))
(letfn [(segment->point [seg]
(let [params (get seg :params)
x (get params :x)
y (get params :y)]
(when (d/num? x y)
(gpt/point x y))))]
(some->> (seq content)
(into [] (keep segment->point)))))
(defn line-values
[[from-p to-p] t]
@ -334,7 +337,7 @@
(->> (curve-extremities curve)
(mapv #(curve-values curve %)))))
[])]
(gpr/points->selrect points))))
(grc/points->rect points))))
(defn content->selrect [content]
(let [calc-extremities
@ -360,7 +363,7 @@
extremities (mapcat calc-extremities
content
(concat [nil] content))]
(gpr/points->selrect extremities)))
(grc/points->rect extremities)))
(defn move-content [content move-vec]
(let [dx (:x move-vec)
@ -591,7 +594,7 @@
(let [[from-p to-p :as curve] (subcurve-range curve from-t to-t)
extremes (->> (curve-extremities curve)
(mapv #(curve-values curve %)))]
(gpr/points->rect (into [from-p to-p] extremes))))
(grc/points->rect (into [from-p to-p] extremes))))
(defn line-has-point?
"Using the line equation we put the x value and check if matches with
@ -623,7 +626,7 @@
[point curve]
(letfn [(check-range [from-t to-t]
(let [r (curve-range->rect curve from-t to-t)]
(when (gpr/contains-point? r point)
(when (grc/contains-point? r point)
(if (s= from-t to-t)
(< (gpt/distance (curve-values curve from-t) point) 0.1)
@ -760,7 +763,7 @@
(let [r1 (curve-range->rect c1 c1-from c1-to)
r2 (curve-range->rect c2 c2-from c2-to)]
(when (gpr/overlaps-rects? r1 r2)
(when (grc/overlaps-rects? r1 r2)
(let [p1 (curve-values c1 c1-from)
p2 (curve-values c2 c2-from)]
@ -811,7 +814,7 @@
[[from-p to-p :as curve]]
(let [extremes (->> (curve-extremities curve)
(mapv #(curve-values curve %)))]
(gpr/points->rect (into [from-p to-p] extremes))))
(grc/points->rect (into [from-p to-p] extremes))))
(defn is-point-in-border?
@ -943,7 +946,7 @@
[content]
(-> content
content->selrect
gsc/center-selrect))
grc/rect->center))
(defn content->points+selrect
"Given the content of a shape, calculate its points and selrect"
@ -960,7 +963,7 @@
flip-y (gmt/scale (gpt/point 1 -1))
:always (gmt/multiply (:transform-inverse shape (gmt/matrix))))
center (or (gsc/center-shape shape)
center (or (gco/shape->center shape)
(content-center content))
base-content (transform-content
@ -969,16 +972,16 @@
;; Calculates the new selrect with points given the old center
points (-> (content->selrect base-content)
(gpr/rect->points)
(gsc/transform-points center transform))
(grc/rect->points)
(gco/transform-points center transform))
points-center (gsc/center-points points)
points-center (gco/points->center points)
;; Points is now the selrect but the center is different so we can create the selrect
;; through points
selrect (-> points
(gsc/transform-points points-center transform-inverse)
(gpr/points->selrect))]
(gco/transform-points points-center transform-inverse)
(grc/points->rect))]
[points selrect]))
(defn open-path?

37
common/src/app/common/geom/shapes/pixel_precision.cljc
View File

@ -8,10 +8,11 @@
(: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]
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.points :as gpo]
[app.common.geom.shapes.rect :as gpr]
[app.common.geom.shapes.transforms :as gtr]
[app.common.math :as mth]
[app.common.pages.helpers :as cph]
@ -19,28 +20,32 @@
(defn size-pixel-precision
[modifiers shape points precision]
(let [origin (gpo/origin points)
curr-width (gpo/width-points points)
curr-height (gpo/height-points points)
(let [origin (gpo/origin points)
curr-width (gpo/width-points points)
curr-height (gpo/height-points points)
[_ transform transform-inverse] (gtr/calculate-geometry points)
center (gco/points->center points)
selrect (gtr/calculate-selrect points center)
path? (cph/path-shape? shape)
vertical-line? (and path? (<= curr-width 0.01))
horizontal-line? (and path? (<= curr-height 0.01))
transform (gtr/calculate-transform points center selrect)
transform-inverse (when (some? transform) (gmt/inverse transform))
target-width (if vertical-line? curr-width (max 1 (mth/round curr-width precision)))
target-height (if horizontal-line? curr-height (max 1 (mth/round curr-height precision)))
path? (cph/path-shape? shape)
vertical-line? (and path? (<= curr-width 0.01))
horizontal-line? (and path? (<= curr-height 0.01))
ratio-width (/ target-width curr-width)
ratio-height (/ target-height curr-height)
scalev (gpt/point ratio-width ratio-height)]
(-> modifiers
(ctm/resize scalev origin transform transform-inverse {:precise? true}))))
target-width (if vertical-line? curr-width (mth/max 1 (mth/round curr-width precision)))
target-height (if horizontal-line? curr-height (mth/max 1 (mth/round curr-height precision)))
ratio-width (/ target-width curr-width)
ratio-height (/ target-height curr-height)
scalev (gpt/point ratio-width ratio-height)]
(ctm/resize modifiers scalev origin transform transform-inverse {:precise? true})))
(defn position-pixel-precision
[modifiers _ points precision ignore-axis]
(let [bounds (gpr/bounds->rect points)
(let [bounds (grc/bounds->rect points)
corner (gpt/point bounds)
target-corner
(cond-> corner

18
common/src/app/common/geom/shapes/points.cljc
View File

@ -8,9 +8,7 @@
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.intersect :as gsi]
[app.common.geom.shapes.rect :as gre]
[app.common.math :as mth]))
(defn origin
@ -104,7 +102,6 @@
(defn parent-coords-bounds
[child-bounds [p1 p2 _ p4 :as parent-bounds]]
(if (empty? child-bounds)
parent-bounds
@ -121,10 +118,10 @@
(fn [[th-min th-max tv-min tv-max] current-point]
(let [cth (project-t current-point rh vv)
ctv (project-t current-point rv hv)]
[(min th-min cth)
(max th-max cth)
(min tv-min ctv)
(max tv-max ctv)]))
[(mth/min th-min cth)
(mth/max th-max cth)
(mth/min tv-min ctv)
(mth/max tv-max ctv)]))
[th-min th-max tv-min tv-max]
(->> child-bounds
@ -152,13 +149,6 @@
[bounds parent-bounds]
(parent-coords-bounds (flatten bounds) parent-bounds))
(defn points->selrect
[points]
(let [width (width-points points)
height (height-points points)
center (gco/center-points points)]
(gre/center->selrect center width height)))
(defn move
[bounds vector]
(->> bounds

219
common/src/app/common/geom/shapes/rect.cljc
View File

@ -4,221 +4,4 @@
;;
;; Copyright (c) KALEIDOS INC
(ns app.common.geom.shapes.rect
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.math :as mth]))
(defn make-rect
([p1 p2]
(let [xp1 (:x p1)
yp1 (:y p1)
xp2 (:x p2)
yp2 (:y p2)
x1 (min xp1 xp2)
y1 (min yp1 yp2)
x2 (max xp1 xp2)
y2 (max yp1 yp2)]
(make-rect x1 y1 (- x2 x1) (- y2 y1))))
([x y width height]
(when (d/num? x y width height)
(let [width (max width 0.01)
height (max height 0.01)]
{:x x
:y y
:width width
:height height}))))
(defn make-selrect
[x y width height]
(when (d/num? x y width height)
(let [width (max width 0.01)
height (max height 0.01)]
{:x x
:y y
:x1 x
:y1 y
:x2 (+ x width)
:y2 (+ y height)
:width width
:height height})))
(defn close-rect?
[rect1 rect2]
(and (mth/close? (:x rect1) (:x rect2))
(mth/close? (:y rect1) (:y rect2))
(mth/close? (:width rect1) (:width rect2))
(mth/close? (:height rect1) (:height rect2))))
(defn close-selrect?
[selrect1 selrect2]
(and (mth/close? (:x selrect1) (:x selrect2))
(mth/close? (:y selrect1) (:y selrect2))
(mth/close? (:x1 selrect1) (:x1 selrect2))
(mth/close? (:y1 selrect1) (:y1 selrect2))
(mth/close? (:x2 selrect1) (:x2 selrect2))
(mth/close? (:y2 selrect1) (:y2 selrect2))
(mth/close? (:width selrect1) (:width selrect2))
(mth/close? (:height selrect1) (:height selrect2))))
(defn rect->points [{:keys [x y width height]}]
(when (d/num? x y)
(let [width (max width 0.01)
height (max height 0.01)]
[(gpt/point x y)
(gpt/point (+ x width) y)
(gpt/point (+ x width) (+ y height))
(gpt/point x (+ y height))])))
(defn rect->lines [{:keys [x y width height]}]
(when (d/num? x y)
(let [width (max width 0.01)
height (max height 0.01)]
[[(gpt/point x y) (gpt/point (+ x width) y)]
[(gpt/point (+ x width) y) (gpt/point (+ x width) (+ y height))]
[(gpt/point (+ x width) (+ y height)) (gpt/point x (+ y height))]
[(gpt/point x (+ y height)) (gpt/point x y)]])))
(defn points->rect
[points]
(when-let [points (seq points)]
(loop [minx ##Inf
miny ##Inf
maxx ##-Inf
maxy ##-Inf
pts points]
(if-let [pt (first pts)]
(let [x (dm/get-prop pt :x)
y (dm/get-prop pt :y)]
(recur (min minx x)
(min miny y)
(max maxx x)
(max maxy y)
(rest pts)))
(when (d/num? minx miny maxx maxy)
(make-rect minx miny (- maxx minx) (- maxy miny)))))))
(defn bounds->rect
[[{ax :x ay :y} {bx :x by :y} {cx :x cy :y} {dx :x dy :y}]]
(let [minx (min ax bx cx dx)
miny (min ay by cy dy)
maxx (max ax bx cx dx)
maxy (max ay by cy dy)]
(when (d/num? minx miny maxx maxy)
(make-rect minx miny (- maxx minx) (- maxy miny)))))
(defn squared-points
[points]
(when (d/not-empty? points)
(let [minx (transduce (keep :x) min ##Inf points)
miny (transduce (keep :y) min ##Inf points)
maxx (transduce (keep :x) max ##-Inf points)
maxy (transduce (keep :y) max ##-Inf points)]
(when (d/num? minx miny maxx maxy)
[(gpt/point minx miny)
(gpt/point maxx miny)
(gpt/point maxx maxy)
(gpt/point minx maxy)]))))
(defn points->selrect [points]
(when-let [rect (points->rect points)]
(let [{:keys [x y width height]} rect]
(make-selrect x y width height))))
(defn rect->selrect [rect]
(-> rect rect->points points->selrect))
(defn join-rects [rects]
(when (d/not-empty? rects)
(let [minx (transduce (keep :x) min ##Inf rects)
miny (transduce (keep :y) min ##Inf rects)
maxx (transduce (keep #(when (and (:x %) (:width %)) (+ (:x %) (:width %)))) max ##-Inf rects)
maxy (transduce (keep #(when (and (:y %) (:height %))(+ (:y %) (:height %)))) max ##-Inf rects)]
(when (d/num? minx miny maxx maxy)
(make-rect minx miny (- maxx minx) (- maxy miny))))))
(defn join-selrects [selrects]
(when (d/not-empty? selrects)
(let [minx (transduce (keep :x1) min ##Inf selrects)
miny (transduce (keep :y1) min ##Inf selrects)
maxx (transduce (keep :x2) max ##-Inf selrects)
maxy (transduce (keep :y2) max ##-Inf selrects)]
(when (d/num? minx miny maxx maxy)
(make-selrect minx miny (- maxx minx) (- maxy miny))))))
(defn center->rect [{:keys [x y]} width height]
(when (d/num? x y width height)
(make-rect (- x (/ width 2))
(- y (/ height 2))
width
height)))
(defn center->selrect [{:keys [x y]} width height]
(when (d/num? x y width height)
(make-selrect (- x (/ width 2))
(- y (/ height 2))
width
height)))
(defn s=
[a b]
(mth/almost-zero? (- a b)))
(defn overlaps-rects?
"Check for two rects to overlap. Rects won't overlap only if
one of them is fully to the left or the top"
[rect-a rect-b]
(let [x1a (:x rect-a)
y1a (:y rect-a)
x2a (+ (:x rect-a) (:width rect-a))
y2a (+ (:y rect-a) (:height rect-a))
x1b (:x rect-b)
y1b (:y rect-b)
x2b (+ (:x rect-b) (:width rect-b))
y2b (+ (:y rect-b) (:height rect-b))]
(and (or (> x2a x1b) (s= x2a x1b))
(or (>= x2b x1a) (s= x2b x1a))
(or (<= y1b y2a) (s= y1b y2a))
(or (<= y1a y2b) (s= y1a y2b)))))
(defn contains-point?
[rect point]
(assert (gpt/point? point))
(let [x1 (:x rect)
y1 (:y rect)
x2 (+ (:x rect) (:width rect))
y2 (+ (:y rect) (:height rect))
px (:x point)
py (:y point)]
(and (or (> px x1) (s= px x1))
(or (< px x2) (s= px x2))
(or (> py y1) (s= py y1))
(or (< py y2) (s= py y2)))))
(defn contains-selrect?
"Check if a selrect sr2 is contained inside sr1"
[sr1 sr2]
(and (>= (:x1 sr2) (:x1 sr1))
(<= (:x2 sr2) (:x2 sr1))
(>= (:y1 sr2) (:y1 sr1))
(<= (:y2 sr2) (:y2 sr1))))
(defn corners->selrect
([p1 p2]
(corners->selrect (:x p1) (:y p1) (:x p2) (:y p2)))
([xp1 yp1 xp2 yp2]
(make-selrect (min xp1 xp2) (min yp1 yp2) (abs (- xp1 xp2)) (abs (- yp1 yp2)))))
(defn clip-selrect
[{:keys [x1 y1 x2 y2] :as sr} clip-rect]
(when (some? sr)
(let [{bx1 :x1 by1 :y1 bx2 :x2 by2 :y2 :as sr2} (rect->selrect clip-rect)]
(corners->selrect (max bx1 x1) (max by1 y1) (min bx2 x2) (min by2 y2)))))
(ns app.common.geom.shapes.rect)

37
common/src/app/common/geom/shapes/text.cljc
View File

@ -6,41 +6,36 @@
(ns app.common.geom.shapes.text
(:require
[app.common.data.macros :as dm]
[app.common.geom.rect :as grc]
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.rect :as gpr]
[app.common.geom.shapes.transforms :as gtr]))
(defn position-data->rect
[{:keys [x y width height]}]
{:x x
:y (- y height)
:width width
:height height})
(grc/make-rect x (- y height) width height))
(defn position-data-selrect
(defn shape->rect
[shape]
(let [points (->> shape
:position-data
(mapcat (comp gpr/rect->points position-data->rect)))]
(if (empty? points)
(:selrect shape)
(-> points (gpr/points->selrect)))))
(let [points (->> (:position-data shape)
(mapcat (comp grc/rect->points position-data->rect)))]
(if (seq points)
(grc/points->rect points)
(dm/get-prop shape :selrect))))
(defn position-data-bounding-box
(defn shape->bounds
[shape]
(let [points (->> shape
:position-data
(mapcat (comp gpr/rect->points position-data->rect)))
transform (gtr/transform-matrix shape)]
(let [points (->> (:position-data shape)
(mapcat (comp grc/rect->points position-data->rect)))]
(-> points
(gco/transform-points transform)
(gpr/points->selrect ))))
(gco/transform-points (gtr/transform-matrix shape))
(grc/points->rect))))
(defn overlaps-position-data?
"Checks if the given position data is inside the shape"
[{:keys [points]} position-data]
(let [bounding-box (gpr/points->selrect points)
(let [bounding-box (grc/points->rect points)
fix-rect #(assoc % :y (- (:y %) (:height %)))]
(->> position-data
(some #(gpr/overlaps-rects? bounding-box (fix-rect %)))
(some #(grc/overlaps-rects? bounding-box (fix-rect %)))
(boolean))))

491
common/src/app/common/geom/shapes/transforms.cljc
View File

@ -5,97 +5,114 @@
;; Copyright (c) KALEIDOS INC
(ns app.common.geom.shapes.transforms
#?(:clj (:import (org.la4j Matrix LinearAlgebra))
:cljs (:import goog.math.Matrix))
(:require
#?(:clj [app.common.exceptions :as ex])
[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]
[app.common.geom.shapes.bool :as gshb]
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.path :as gpa]
[app.common.geom.shapes.rect :as gpr]
[app.common.math :as mth]
[app.common.pages.helpers :as cph]
[app.common.types.modifiers :as ctm]
[app.common.uuid :as uuid]))
[app.common.record :as cr]
[app.common.types.modifiers :as ctm]))
#?(:clj (set! *warn-on-reflection* true))
(defn- valid-point?
[o]
(and ^boolean (gpt/point? o)
^boolean (d/num? (dm/get-prop o :x)
(dm/get-prop o :y))))
;; --- Relative Movement
(defn- move-selrect [{:keys [x y x1 y1 x2 y2 width height] :as selrect} {dx :x dy :y :as pt}]
(if (and (some? selrect) (some? pt) (d/num? dx dy))
{:x (if (d/num? x) (+ dx x) x)
:y (if (d/num? y) (+ dy y) y)
:x1 (if (d/num? x1) (+ dx x1) x1)
:y1 (if (d/num? y1) (+ dy y1) y1)
:x2 (if (d/num? x2) (+ dx x2) x2)
:y2 (if (d/num? y2) (+ dy y2) y2)
:width width
:height height}
(defn- move-selrect
[selrect pt]
(if (and ^boolean (some? selrect)
^boolean (valid-point? pt))
(let [x (dm/get-prop selrect :x)
y (dm/get-prop selrect :y)
w (dm/get-prop selrect :width)
h (dm/get-prop selrect :height)
dx (dm/get-prop pt :x)
dy (dm/get-prop pt :y)]
(grc/make-rect
(if ^boolean (d/num? x) (+ dx x) x)
(if ^boolean (d/num? y) (+ dy y) y)
w
h))
selrect))
(defn- move-points [points move-vec]
(cond->> points
(d/num? (:x move-vec) (:y move-vec))
(mapv #(gpt/add % move-vec))))
(defn- move-points
[points move-vec]
(if (valid-point? move-vec)
(mapv #(gpt/add % move-vec) points)
points))
;; FIXME: deprecated
(defn move-position-data
([position-data {:keys [x y]}]
(move-position-data position-data x y))
([position-data dx dy]
(when (some? position-data)
(cond->> position-data
(d/num? dx dy)
(mapv #(-> %
[position-data delta]
(when (some? position-data)
(let [dx (dm/get-prop delta :x)
dy (dm/get-prop delta :y)]
(if (d/num? dx dy)
(mapv #(-> %
(update :x + dx)
(update :y + dy)))))))
(update :y + dy))
position-data)
position-data))))
(defn transform-position-data
[position-data transform]
(when (some? position-data)
(let [dx (dm/get-prop transform :e)
dy (dm/get-prop transform :f)]
(if (d/num? dx dy)
(mapv #(-> %
(update :x + dx)
(update :y + dy))
position-data)
position-data))))
;; FIXME: revist usage of mutability
(defn move
"Move the shape relatively to its current
position applying the provided delta."
[{:keys [type] :as shape} {dx :x dy :y}]
(let [dx (d/check-num dx 0)
dy (d/check-num dy 0)
move-vec (gpt/point dx dy)]
[shape point]
(let [type (dm/get-prop shape :type)
dx (dm/get-prop point :x)
dy (dm/get-prop point :y)
dx (d/check-num dx 0)
dy (d/check-num dy 0)
mvec (gpt/point dx dy)]
(-> shape
(update :selrect move-selrect move-vec)
(update :points move-points move-vec)
(d/update-when :x + dx)
(d/update-when :y + dy)
(d/update-when :position-data move-position-data dx dy)
(cond-> (= :bool type) (update :bool-content gpa/move-content move-vec))
(cond-> (= :path type) (update :content gpa/move-content move-vec)))))
(update :selrect move-selrect mvec)
(update :points move-points mvec)
(d/update-when :x d/safe+ dx)
(d/update-when :y d/safe+ dy)
(d/update-when :position-data move-position-data mvec)
(cond-> (= :bool type) (update :bool-content gpa/move-content mvec))
(cond-> (= :path type) (update :content gpa/move-content mvec)))))
;; --- Absolute Movement
(defn absolute-move
"Move the shape to the exactly specified position."
[shape {:keys [x y]}]
(let [dx (- (d/check-num x) (-> shape :selrect :x))
dy (- (d/check-num y) (-> shape :selrect :y))]
[shape pos]
(let [x (dm/get-prop pos :x)
y (dm/get-prop pos :y)
sr (dm/get-prop shape :selrect)
px (dm/get-prop sr :x)
py (dm/get-prop sr :y)
dx (- (d/check-num x) px)
dy (- (d/check-num y) py)]
(move shape (gpt/point dx dy))))
; ---- Geometric operations
(defn- calculate-height
"Calculates the height of a parallelogram given by the points"
[[p1 _ _ p4]]
(-> (gpt/to-vec p4 p1)
(gpt/length)))
(defn- calculate-width
"Calculates the width of a parallelogram given by the points"
[[p1 p2 _ _]]
(-> (gpt/to-vec p1 p2)
(gpt/length)))
;; --- Transformation matrix operations
(defn transform-matrix
@ -105,7 +122,7 @@
(transform-matrix shape nil))
([shape params]
(transform-matrix shape params (or (gco/center-shape shape) (gpt/point 0 0))))
(transform-matrix shape params (or (gco/shape->center shape) (gpt/point 0 0))))
([{:keys [flip-x flip-y transform] :as shape} {:keys [no-flip]} shape-center]
(-> (gmt/matrix)
@ -134,9 +151,10 @@
(dm/str (transform-matrix shape params))
"")))
;; FIXME: performance
(defn inverse-transform-matrix
([shape]
(let [shape-center (or (gco/center-shape shape)
(let [shape-center (or (gco/shape->center shape)
(gpt/point 0 0))]
(inverse-transform-matrix shape shape-center)))
([{:keys [flip-x flip-y] :as shape} center]
@ -148,217 +166,214 @@
(gmt/multiply (:transform-inverse shape (gmt/matrix)))
(gmt/translate (gpt/negate center)))))
;; FIXME: move to geom rect?
(defn transform-rect
"Transform a rectangles and changes its attributes"
[rect matrix]
(let [points (-> (gpr/rect->points rect)
(let [points (-> (grc/rect->points rect)
(gco/transform-points matrix))]
(gpr/points->rect points)))
(grc/points->rect points)))
(defn transform-points-matrix
"Calculate the transform matrix to convert from the selrect to the points bounds
TargetM = SourceM * Transform ==> Transform = TargetM * inv(SourceM)"
[{:keys [x1 y1 x2 y2]} [d1 d2 _ d4]]
[selrect [d1 d2 _ d4]]
;; If the coordinates are very close to zero (but not zero) the rounding can mess with the
;; transforms. So we round to zero the values
(let [x1 (mth/round-to-zero x1)
y1 (mth/round-to-zero y1)
x2 (mth/round-to-zero x2)
y2 (mth/round-to-zero y2)
d1x (mth/round-to-zero (:x d1))
d1y (mth/round-to-zero (:y d1))
d2x (mth/round-to-zero (:x d2))
d2y (mth/round-to-zero (:y d2))
d4x (mth/round-to-zero (:x d4))
d4y (mth/round-to-zero (:y d4))]
#?(:clj
;; NOTE: the source matrix may not be invertible we can't
;; calculate the transform, so on exception we return `nil`
(ex/ignoring
(let [target-points-matrix
(->> (list d1x d2x d4x
d1y d2y d4y
1 1 1)
(into-array Double/TYPE)
(Matrix/from1DArray 3 3))
(let [x1 (mth/round-to-zero (dm/get-prop selrect :x1))
y1 (mth/round-to-zero (dm/get-prop selrect :y1))
x2 (mth/round-to-zero (dm/get-prop selrect :x2))
y2 (mth/round-to-zero (dm/get-prop selrect :y2))
source-points-matrix
(->> (list x1 x2 x1
y1 y1 y2
1 1 1)
(into-array Double/TYPE)
(Matrix/from1DArray 3 3))
det (+ (- (* (- y1 y2) x1)
(* (- y1 y2) x2))
(* (- y1 y1) x1))]
;; May throw an exception if the matrix is not invertible
source-points-matrix-inv
(.. source-points-matrix
(withInverter LinearAlgebra/GAUSS_JORDAN)
(inverse))
(when-not (zero? det)
(let [ma0 (mth/round-to-zero (dm/get-prop d1 :x))
ma1 (mth/round-to-zero (dm/get-prop d2 :x))
ma2 (mth/round-to-zero (dm/get-prop d4 :x))
ma3 (mth/round-to-zero (dm/get-prop d1 :y))
ma4 (mth/round-to-zero (dm/get-prop d2 :y))
ma5 (mth/round-to-zero (dm/get-prop d4 :y))
transform-jvm
(.. target-points-matrix
(multiply source-points-matrix-inv))]
mb0 (/ (- y1 y2) det)
mb1 (/ (- x1 x2) det)
mb2 (/ (- (* x2 y2) (* x1 y1)) det)
mb3 (/ (- y2 y1) det)
mb4 (/ (- x1 x1) det)
mb5 (/ (- (* x1 y1) (* x1 y2)) det)
mb6 (/ (- y1 y1) det)
mb7 (/ (- x2 x1) det)
mb8 (/ (- (* x1 y1) (* x2 y1)) det)]
(gmt/matrix (.get transform-jvm 0 0)
(.get transform-jvm 1 0)
(.get transform-jvm 0 1)
(.get transform-jvm 1 1)
(.get transform-jvm 0 2)
(.get transform-jvm 1 2))))
(gmt/matrix (+ (* ma0 mb0)
(* ma1 mb3)
(* ma2 mb6))
(+ (* ma3 mb0)
(* ma4 mb3)
(* ma5 mb6))
(+ (* ma0 mb1)
(* ma1 mb4)
(* ma2 mb7))
(+ (* ma3 mb1)
(* ma4 mb4)
(* ma5 mb7))
(+ (* ma0 mb2)
(* ma1 mb5)
(* ma2 mb8))
(+ (* ma3 mb2)
(* ma4 mb5)
(* ma5 mb8)))))))
:cljs
(let [target-points-matrix
(Matrix. #js [#js [d1x d2x d4x]
#js [d1y d2y d4y]
#js [ 1 1 1]])
(defn calculate-selrect
[points center]
source-points-matrix
(Matrix. #js [#js [x1 x2 x1]
#js [y1 y1 y2]
#js [ 1 1 1]])
(let [p1 (nth points 0)
p2 (nth points 1)
p4 (nth points 3)
;; returns nil if not invertible
source-points-matrix-inv (.getInverse source-points-matrix)
width (mth/hypot
(- (dm/get-prop p2 :x)
(dm/get-prop p1 :x))
(- (dm/get-prop p2 :y)
(dm/get-prop p1 :y)))
;; TargetM = SourceM * Transform ==> Transform = TargetM * inv(SourceM)
transform-js
(when source-points-matrix-inv
(.multiply target-points-matrix source-points-matrix-inv))]
height (mth/hypot
(- (dm/get-prop p1 :x)
(dm/get-prop p4 :x))
(- (dm/get-prop p1 :y)
(dm/get-prop p4 :y)))]
(when transform-js
(gmt/matrix (.getValueAt transform-js 0 0)
(.getValueAt transform-js 1 0)
(.getValueAt transform-js 0 1)
(.getValueAt transform-js 1 1)
(.getValueAt transform-js 0 2)
(.getValueAt transform-js 1 2)))))))
(grc/center->rect center width height)))
(defn calculate-geometry
[points]
(let [width (calculate-width points)
height (calculate-height points)
center (gco/center-points points)
sr (gpr/center->selrect center width height)
points-transform-mtx (transform-points-matrix sr points)
(defn calculate-transform
[points center selrect]
(let [transform (transform-points-matrix selrect points)
;; Calculate the transform by move the transformation to the center
transform
(when points-transform-mtx
(gmt/multiply
(gmt/translate-matrix (gpt/negate center))
points-transform-mtx
(gmt/translate-matrix center)))
(when (some? transform)
(-> (gmt/translate-matrix-neg center)
(gmt/multiply! transform)
(gmt/multiply! (gmt/translate-matrix center))))]
transform-inverse (when transform (gmt/inverse transform))
;; There is a rounding error when the matrix returned have float point values
;; when the matrix is unit we return a "pure" matrix so we don't accumulate
;; rounding problems
(when ^boolean (gmt/matrix? transform)
(if ^boolean (gmt/unit? transform)
gmt/base
transform))))
;; There is a rounding error when the matrix returned have float point values
;; when the matrix is unit we return a "pure" matrix so we don't accumulate
;; rounding problems
[transform transform-inverse]
(if (gmt/unit? transform)
[(gmt/matrix) (gmt/matrix)]
[transform transform-inverse])]
(defn calculate-geometry
[points]
(let [center (gco/points->center points)
selrect (calculate-selrect points center)
transform (calculate-transform points center selrect)]
[selrect transform (when (some? transform) (gmt/inverse transform))]))
[sr transform transform-inverse]))
(defn- adjust-shape-flips
(defn- adjust-shape-flips!
"After some tranformations the flip-x/flip-y flags can change we need
to check this before adjusting the selrect"
[shape points]
(let [points' (dm/get-prop shape :points)
p0' (nth points' 0)
p0 (nth points 0)
(let [points' (:points shape)
;; FIXME: unroll and remove point allocation here
xv1 (gpt/to-vec p0' (nth points' 1))
xv2 (gpt/to-vec p0 (nth points 1))
dot-x (gpt/dot xv1 xv2)
xv1 (gpt/to-vec (nth points' 0) (nth points' 1))
xv2 (gpt/to-vec (nth points 0) (nth points 1))
dot-x (gpt/dot xv1 xv2)
yv1 (gpt/to-vec (nth points' 0) (nth points' 3))
yv2 (gpt/to-vec (nth points 0) (nth points 3))
dot-y (gpt/dot yv1 yv2)]
yv1 (gpt/to-vec p0' (nth points' 3))
yv2 (gpt/to-vec p0 (nth points 3))
dot-y (gpt/dot yv1 yv2)]
(cond-> shape
(neg? dot-x)
(-> (update :flip-x not)
(update :rotation -))
(-> (cr/update! :flip-x not)
(cr/update! :rotation -))
(neg? dot-y)
(-> (update :flip-y not)
(update :rotation -)))))
(-> (cr/update! :flip-y not)
(cr/update! :rotation -)))))
(defn- apply-transform-move
"Given a new set of points transformed, set up the rectangle so it keeps
its properties. We adjust de x,y,width,height and create a custom transform"
[shape transform-mtx]
(let [bool? (= (:type shape) :bool)
path? (= (:type shape) :path)
text? (= (:type shape) :text)
{dx :x dy :y} (gpt/transform (gpt/point) transform-mtx)
points (gco/transform-points (:points shape) transform-mtx)
selrect (gco/transform-selrect (:selrect shape) transform-mtx)]
(let [type (dm/get-prop shape :type)
points (gco/transform-points (dm/get-prop shape :points) transform-mtx)
selrect (gco/transform-selrect (dm/get-prop shape :selrect) transform-mtx)
;; NOTE: ensure we start with a fresh copy of shape for mutabilty
shape (cr/clone shape)
shape (if (= type :bool)
(update shape :bool-content gpa/transform-content transform-mtx)
shape)
shape (if (= type :text)
(update shape :position-data move-position-data transform-mtx)
shape)
shape (if (= type :path)
(update shape :content gpa/transform-content transform-mtx)
(cr/assoc! shape
:x (dm/get-prop selrect :x)
:y (dm/get-prop selrect :y)
:width (dm/get-prop selrect :width)
:height (dm/get-prop selrect :height)))]
(-> shape
(cond-> bool?
(update :bool-content gpa/transform-content transform-mtx))
(cond-> path?
(update :content gpa/transform-content transform-mtx))
(cond-> text?
(update :position-data move-position-data dx dy))
(cond-> (not path?)
(assoc :x (:x selrect)
:y (:y selrect)
:width (:width selrect)
:height (:height selrect)))
(assoc :selrect selrect)
(assoc :points points))))
(cr/assoc! :selrect selrect)
(cr/assoc! :points points))))
(defn- apply-transform-generic
"Given a new set of points transformed, set up the rectangle so it keeps
its properties. We adjust de x,y,width,height and create a custom transform"
[shape transform-mtx]
(let [points (-> (dm/get-prop shape :points)
(gco/transform-points transform-mtx))
(let [points' (:points shape)
points (gco/transform-points points' transform-mtx)
shape (-> shape (adjust-shape-flips points))
bool? (= (:type shape) :bool)
path? (= (:type shape) :path)
;; NOTE: ensure we have a fresh shallow copy of shape
shape (cr/clone shape)
shape (adjust-shape-flips! shape points)
[selrect transform transform-inverse] (calculate-geometry points)
center (gco/points->center points)
selrect (calculate-selrect points center)
transform (calculate-transform points center selrect)
inverse (when (some? transform) (gmt/inverse transform))
base-rotation (or (:rotation shape) 0)
modif-rotation (or (get-in shape [:modifiers :rotation]) 0)
rotation (mod (+ base-rotation modif-rotation) 360)]
]
(if-not (and transform transform-inverse)
;; When we cannot calculate the transformation we leave the shape as it was
(if-not (and (some? inverse) (some? transform))
shape
(-> shape
(cond-> bool?
(update :bool-content gpa/transform-content transform-mtx))
(cond-> path?
(update :content gpa/transform-content transform-mtx))
(cond-> (not path?)
(assoc :x (:x selrect)
:y (:y selrect)
:width (:width selrect)
:height (:height selrect)))
(cond-> transform
(-> (assoc :transform transform)
(assoc :transform-inverse transform-inverse)))
(cond-> (not transform)
(dissoc :transform :transform-inverse))
(cond-> (some? selrect)
(assoc :selrect selrect))
(let [type (dm/get-prop shape :type)
rotation (mod (+ (d/nilv (:rotation shape) 0)
(d/nilv (dm/get-in shape [:modifiers :rotation]) 0))
360)
shape (if (= type :bool)
(update shape :bool-content gpa/transform-content transform-mtx)
shape)
(cond-> (d/not-empty? points)
(assoc :points points))
(assoc :rotation rotation)))))
shape (if (= type :path)
(update shape :content gpa/transform-content transform-mtx)
(cr/assoc! shape
:x (dm/get-prop selrect :x)
:y (dm/get-prop selrect :y)
:width (dm/get-prop selrect :width)
:height (dm/get-prop selrect :height)))]
(-> shape
(cr/assoc! :transform transform)
(cr/assoc! :transform-inverse inverse)
(cr/assoc! :selrect selrect)
(cr/assoc! :points points)
(cr/assoc! :rotation rotation))))))
(defn- apply-transform
"Given a new set of points transformed, set up the rectangle so it keeps
its properties. We adjust de x,y,width,height and create a custom transform"
[shape transform-mtx]
(if (gmt/move? transform-mtx)
(if ^boolean (gmt/move? transform-mtx)
(apply-transform-move shape transform-mtx)
(apply-transform-generic shape transform-mtx)))
@ -385,7 +400,7 @@
(let [;; Points for every shape inside the group
points (->> children (mapcat :points))
shape-center (gco/center-points points)
shape-center (gco/points->center points)
;; Fixed problem with empty groups. Should not happen (but it does)
points (if (empty? points) (:points group) points)
@ -393,13 +408,14 @@
;; Invert to get the points minus the transforms applied to the group
base-points (gco/transform-points points shape-center (:transform-inverse group (gmt/matrix)))
;; FIXME: looks redundant operation points -> rect -> points
;; Defines the new selection rect with its transformations
new-points (-> (gpr/points->selrect base-points)
(gpr/rect->points)
new-points (-> (grc/points->rect base-points)
(grc/rect->points)
(gco/transform-points shape-center (:transform group (gmt/matrix))))
;; Calculate the new selrect
new-selrect (gpr/points->selrect base-points)]
new-selrect (grc/points->rect base-points)]
;; Updates the shape and the applytransform-rect will update the other properties
(-> group
@ -448,21 +464,16 @@
(transform-shape modifiers))))
([shape modifiers]
(letfn [(apply-modifiers
[shape modifiers]
(if (ctm/empty? modifiers)
shape
(let [transform (ctm/modifiers->transform modifiers)]
(cond-> shape
(and (some? transform) (not= uuid/zero (:id shape))) ;; Never transform the root frame
(apply-transform transform)
(if (and (some? modifiers) (not (ctm/empty? modifiers)))
(let [transform (ctm/modifiers->transform modifiers)]
(cond-> shape
(and (some? transform)
(not (cph/root? shape)))
(apply-transform transform)
(ctm/has-structure? modifiers)
(ctm/apply-structure-modifiers modifiers)))))]
(cond-> shape
(and (some? modifiers) (not (ctm/empty? modifiers)))
(apply-modifiers modifiers)))))
(ctm/has-structure? modifiers)
(ctm/apply-structure-modifiers modifiers)))
shape)))
(defn apply-objects-modifiers
([objects modifiers]
@ -492,24 +503,16 @@
(defn transform-selrect
[selrect modifiers]
(-> selrect
(gpr/rect->points)
(grc/rect->points)
(transform-bounds modifiers)
(gpr/points->selrect)))
(grc/points->rect)))
(defn transform-selrect-matrix
[selrect mtx]
(-> selrect
(gpr/rect->points)
(grc/rect->points)
(gco/transform-points mtx)
(gpr/points->selrect)))
(defn selection-rect
"Returns a rect that contains all the shapes and is aware of the
rotation of each shape. Mainly used for multiple selection."
[shapes]
(->> shapes
(map (comp gpr/points->selrect :points transform-shape))
(gpr/join-selrects)))
(grc/points->rect)))
(declare apply-group-modifiers)

61
common/src/app/common/geom/snap.cljc Normal file
View File

@ -0,0 +1,61 @@
;; 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) KALEIDOS INC
(ns app.common.geom.snap
(:require
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.pages.helpers :as cph]
[app.common.types.shape-tree :as ctst]))
(defn rect->snap-points
[rect]
(let [x (dm/get-prop rect :x)
y (dm/get-prop rect :y)
w (dm/get-prop rect :width)
h (dm/get-prop rect :height)]
#{(gpt/point x y)
(gpt/point (+ x w) y)
(gpt/point (+ x w) (+ y h))
(gpt/point x (+ y h))
(grc/rect->center rect)}))
(defn- frame->snap-points
[frame]
(let [points (dm/get-prop frame :points)
rect (grc/points->rect points)
x (dm/get-prop rect :x)
y (dm/get-prop rect :y)
w (dm/get-prop rect :width)
h (dm/get-prop rect :height)]
(into (rect->snap-points rect)
#{(gpt/point (+ x (/ w 2)) y)
(gpt/point (+ x w) (+ y (/ h 2)))
(gpt/point (+ x (/ w 2)) (+ y h))
(gpt/point x (+ y (/ h 2)))})))
(defn shape->snap-points
[shape]
(if ^boolean (cph/frame-shape? shape)
(frame->snap-points shape)
(->> (dm/get-prop shape :points)
(into #{(gsh/shape->center shape)}))))
(defn guide->snap-points
[guide frame]
(cond
(and (some? frame)
(not ^boolean (ctst/rotated-frame? frame))
(not ^boolean (cph/root-frame? frame)))
#{}
(= :x (:axis guide))
#{(gpt/point (:position guide) 0)}
:else
#{(gpt/point 0 (:position guide))}))

25
common/src/app/common/math.cljc
View File

@ -6,9 +6,24 @@
(ns app.common.math
"A collection of math utils."
(:refer-clojure :exclude [abs])
(:refer-clojure :exclude [abs min max])
#?(:cljs
(:require [goog.math :as math])))
(:require-macros [app.common.math :refer [min max]]))
(:require
#?(:cljs [goog.math :as math])
[clojure.core :as c]))
(defmacro min
[& params]
(if (:ns &env)
`(js/Math.min ~@params)
`(c/min ~@params)))
(defmacro max
[& params]
(if (:ns &env)
`(js/Math.max ~@params)
`(c/max ~@params)))
(def PI
#?(:cljs (.-PI js/Math)
@ -177,7 +192,7 @@
(defn round-to-zero
"Given a number if it's close enough to zero round to the zero to avoid precision problems"
[num]
(if (almost-zero? num)
(if (< (abs num) 1e-4)
0
num))
@ -198,10 +213,12 @@
(defn max-abs
[a b]
(max (abs a) (abs b)))
(max (abs a)
(abs b)))
(defn sign
"Get the sign (+1 / -1) for the number"
[n]
(if (neg? n) -1 1))

25
common/src/app/common/pages.cljc
View File

@ -9,34 +9,11 @@
(:require
[app.common.data.macros :as dm]
[app.common.pages.changes :as changes]
[app.common.pages.common :as common]
[app.common.pages.focus :as focus]
[app.common.pages.indices :as indices]
[app.common.types.file :as ctf]))
;; Common
(dm/export common/root)
(dm/export common/file-version)
(dm/export common/default-color)
(dm/export common/component-sync-attrs)
(dm/export common/retrieve-used-names)
(dm/export common/generate-unique-name)
;; Focus
(dm/export focus/focus-objects)
(dm/export focus/filter-not-focus)
(dm/export focus/is-in-focus?)
[app.common.pages.indices :as indices]))
;; Indices
#_(dm/export indices/calculate-z-index)
#_(dm/export indices/update-z-index)
(dm/export indices/generate-child-all-parents-index)
(dm/export indices/generate-child-parent-index)
(dm/export indices/create-clip-index)
;; Process changes
(dm/export changes/process-changes)
;; Initialization
(dm/export ctf/make-file-data)
(dm/export ctf/empty-file-data)

50
common/src/app/common/pages/changes.cljc
View File

@ -12,7 +12,6 @@
[app.common.exceptions :as ex]
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]
[app.common.pages.common :refer [component-sync-attrs]]
[app.common.pages.helpers :as cph]
[app.common.schema :as sm]
[app.common.schema.desc-native :as smd]
@ -20,6 +19,7 @@
[app.common.types.colors-list :as ctcl]
[app.common.types.component :as ctk]
[app.common.types.components-list :as ctkl]
[app.common.types.component :as ctk]
[app.common.types.container :as ctn]
[app.common.types.file :as ctf]
[app.common.types.page :as ctp]
@ -50,7 +50,7 @@
[:set-remote-synced
[:map {:title "SetRemoteSyncedOperation"}
[:type [:= :set-remote-synced]]
[:remote-synced? [:maybe :boolean]]]]])
[:remote-synced {:optional true} [:maybe :boolean]]]]])
(sm/def! ::change
[:schema
@ -68,11 +68,11 @@
[:map {:title "AddObjChange"}
[:type [:= :add-obj]]
[:id ::sm/uuid]
[:obj [:map-of {:gen/max 10} :keyword :any]]
[:obj :map]
[:page-id {:optional true} ::sm/uuid]
[:component-id {:optional true} ::sm/uuid]
[:frame-id {:optional true} ::sm/uuid]
[:parent-id {:optional true} ::sm/uuid]
[:frame-id ::sm/uuid]
[:parent-id {:optional true} [:maybe ::sm/uuid]]
[:index {:optional true} [:maybe :int]]
[:ignore-touched {:optional true} :boolean]]]
@ -227,11 +227,11 @@
(sm/def! ::changes
[:sequential {:gen/max 2} ::change])
(def change?
(def valid-change?
(sm/pred-fn ::change))
(def changes?
(def valid-changes?
(sm/pred-fn [:sequential ::change]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -258,7 +258,8 @@
;; If object has changed or is new verify is correct
(when (and (some? shape-new)
(not= shape-old shape-new))
(dm/verify! (cts/shape? shape-new)))))]
(dm/verify! (and (cts/shape? shape-new)
(cts/valid-shape? shape-new))))))]
(->> (into #{} (map :page-id) items)
(mapcat (fn [page-id]
@ -283,7 +284,7 @@
;; When verify? false we spec the schema validation. Currently used to make just
;; 1 validation even if the changes are applied twice
(when verify?
(dm/verify! (changes? items)))
(dm/verify! (valid-changes? items)))
(let [result (reduce #(or (process-change %1 %2) %1) data items)]
;; Validate result shapes (only on the backend)
@ -430,7 +431,7 @@
(= :bool (:type group))
(gsh/update-bool-selrect group children objects)
(:masked-group? group)
(:masked-group group)
(set-mask-selrect group children)
:else
@ -474,7 +475,7 @@
(#{:group :frame} (:type parent))
(not ignore-touched))
(-> (update :touched cph/set-touched-group :shapes-group)
(dissoc :remote-synced?)))))
(dissoc :remote-synced)))))
(remove-from-old-parent [old-objects objects shape-id]
(let [prev-parent-id (dm/get-in old-objects [shape-id :parent-id])]
@ -493,7 +494,7 @@
(d/update-in-when [pid :shapes] d/vec-without-nils)
(cond-> component? (d/update-when pid #(-> %
(update :touched cph/set-touched-group :shapes-group)
(dissoc :remote-synced?)))))))))
(dissoc :remote-synced)))))))))
(update-parent-id [objects id]
(-> objects
(d/update-when id assoc :parent-id parent-id)))
@ -639,7 +640,7 @@
(defmethod process-operation :set
[on-changed shape op]
(let [attr (:attr op)
group (get component-sync-attrs attr)
group (get ctk/sync-attrs attr)
val (:val op)
shape-val (get shape attr)
ignore (:ignore-touched op)
@ -675,7 +676,7 @@
(and in-copy? group (not ignore) (not equal?)
(not (and ignore-geometry is-geometry?)))
(-> (update :touched cph/set-touched-group group)
(dissoc :remote-synced?))
(dissoc :remote-synced))
(nil? val)
(dissoc attr)
@ -693,11 +694,11 @@
(defmethod process-operation :set-remote-synced
[_ shape op]
(let [remote-synced? (:remote-synced? op)
(let [remote-synced (:remote-synced op)
in-copy? (ctk/in-component-copy? shape)]
(if (or (not in-copy?) (not remote-synced?))
(dissoc shape :remote-synced?)
(assoc shape :remote-synced? true))))
(if (or (not in-copy?) (not remote-synced))
(dissoc shape :remote-synced)
(assoc shape :remote-synced true))))
(defmethod process-operation :default
[_ _ op]
@ -725,19 +726,18 @@
; We need to trigger a sync if the shape has changed any
; attribute that participates in components synchronization.
(and (= (:type operation) :set)
(component-sync-attrs (:attr operation))))
(get ctk/sync-attrs (:attr operation))))
any-sync? (some need-sync? operations)]
(when any-sync?
(let [xform (comp (filter :main-instance?) ; Select shapes that are main component instances
(let [xform (comp (filter :main-instance) ; Select shapes that are main component instances
(map :component-id))]
(into #{} xform shape-and-parents))))))
(defmethod components-changed :mov-objects
[file-data {:keys [page-id _component-id parent-id shapes] :as change}]
(when page-id
(let [page (ctpl/get-page file-data page-id)
xform (comp (filter :main-instance?)
(let [page (ctpl/get-page file-data page-id)
xform (comp (filter :main-instance)
(map :component-id))
check-shape
@ -756,7 +756,7 @@
(let [page (ctpl/get-page file-data page-id)
shape-and-parents (map (partial ctn/get-shape page)
(cons id (cph/get-parent-ids (:objects page) id)))
xform (comp (filter :main-instance?)
xform (comp (filter :main-instance)
(map :component-id))]
(into #{} xform shape-and-parents))))

18
common/src/app/common/pages/changes_builder.cljc
View File

@ -11,6 +11,7 @@
[app.common.files.features :as ffeat]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]
[app.common.pages :as cp]
@ -217,6 +218,9 @@
(add-object changes obj nil))
([changes obj {:keys [index ignore-touched] :or {index ::undefined ignore-touched false}}]
;; FIXME: add shape validation
(assert-page-id changes)
(assert-objects changes)
(let [obj (cond-> obj
@ -234,7 +238,7 @@
:frame-id (:frame-id obj)
:index (::index obj)
:ignore-touched ignore-touched
:obj (dissoc obj ::index :parent-id)}
:obj (dissoc obj ::index)}
del-change
{:type :del-obj
@ -469,7 +473,7 @@
(every? #(apply gpt/close? %) (d/zip old-val new-val))
(= attr :selrect)
(gsh/close-selrect? old-val new-val)
(grc/close-rect? old-val new-val)
:else
(= old-val new-val))]
@ -491,7 +495,7 @@
(gsh/update-bool-selrect parent children objects)
(= (:type parent) :group)
(if (:masked-group? parent)
(if (:masked-group parent)
(gsh/update-mask-selrect parent children)
(gsh/update-group-selrect parent children)))]
(if resized-parent
@ -624,11 +628,11 @@
:attr :component-file
:val (:component-file shape)}
{:type :set
:attr :component-root?
:val (:component-root? shape)}
:attr :component-root
:val (:component-root shape)}
{:type :set
:attr :main-instance?
:val (:main-instance? shape)}
:attr :main-instance
:val (:main-instance shape)}
{:type :set
:attr :shape-ref
:val (:shape-ref shape)}

101
common/src/app/common/pages/helpers.cljc
View File

@ -22,8 +22,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn root?
[{:keys [id type]}]
(and (= type :frame) (= id uuid/zero)))
[shape]
(and (= (dm/get-prop shape :type) :frame)
(= (dm/get-prop shape :id) uuid/zero)))
(defn root-frame?
([objects id]
@ -35,60 +36,71 @@
(defn frame-shape?
([objects id]
(frame-shape? (get objects id)))
([{:keys [type]}]
(= type :frame)))
([shape]
(and (some? shape)
(= :frame (dm/get-prop shape :type)))))
(defn group-shape?
([objects id]
(group-shape? (get objects id)))
([{:keys [type]}]
(= type :group)))
([shape]
(and (some? shape)
(= :group (dm/get-prop shape :type)))))
(defn mask-shape?
([shape]
(and ^boolean (group-shape? shape)
^boolean (:masked-group shape)))
([objects id]
(mask-shape? (get objects id)))
([{:keys [type masked-group?]}]
(and (= type :group) masked-group?)))
(mask-shape? (get objects id))))
(defn bool-shape?
[{:keys [type]}]
(= type :bool))
[shape]
(and (some? shape)
(= :bool (dm/get-prop shape :type))))
(defn group-like-shape?
[{:keys [type]}]
(or (= :group type) (= :bool type)))
[shape]
(or ^boolean (group-shape? shape)
^boolean (bool-shape? shape)))
(defn text-shape?
[{:keys [type]}]
(= type :text))
[shape]
(and (some? shape)
(= :text (dm/get-prop shape :type))))
(defn rect-shape?
[{:keys [type]}]
(= type :rect))
[shape]
(and (some? shape)
(= :rect (dm/get-prop shape :type))))
(defn circle-shape?
[{:keys [type]}]
(= type :circle))
(defn image-shape?
[{:keys [type]}]
(= type :image))
[shape]
(and (some? shape)
(= :image (dm/get-prop shape :type))))
(defn svg-raw-shape?
[{:keys [type]}]
(= type :svg-raw))
[shape]
(and (some? shape)
(= :svg-raw (dm/get-prop shape :type))))
(defn path-shape?
([objects id]
(path-shape? (get objects id)))
([{:keys [type]}]
(= type :path)))
([shape]
(and (some? shape)
(= :path (dm/get-prop shape :type)))))
(defn unframed-shape?
"Checks if it's a non-frame shape in the top level."
[shape]
(and (not (frame-shape? shape))
(= (:frame-id shape) uuid/zero)))
(and (some? shape)
(not (frame-shape? shape))
(= (dm/get-prop shape :frame-id) uuid/zero)))
(defn has-children?
([objects id]
@ -96,10 +108,11 @@
([shape]
(d/not-empty? (:shapes shape))))
;; ---- ACCESSORS
(defn get-children-ids
[objects id]
(letfn [(get-children-ids-rec
[id processed]
(letfn [(get-children-ids-rec [id processed]
(when (not (contains? processed id))
(when-let [shapes (-> (get objects id) :shapes (some-> vec))]
(into shapes (mapcat #(get-children-ids-rec % (conj processed id))) shapes))))]
@ -120,19 +133,21 @@
(defn get-parent
"Retrieve the id of the parent for the shape-id (if exists)"
[objects id]
(let [lookup (d/getf objects)]
(-> id lookup :parent-id lookup)))
(when-let [shape (get objects id)]
(get objects (dm/get-prop shape :parent-id))))
(defn get-parent-id
"Retrieve the id of the parent for the shape-id (if exists)"
[objects id]
(-> objects (get id) :parent-id))
(when-let [shape (get objects id)]
(dm/get-prop shape :parent-id)))
(defn get-parent-ids
"Returns a vector of parents of the specified shape."
[objects shape-id]
(loop [result [] id shape-id]
(let [parent-id (dm/get-in objects [id :parent-id])]
(loop [result []
id shape-id]
(let [parent-id (get-parent-id objects id)]
(if (and (some? parent-id) (not= parent-id id))
(recur (conj result parent-id) parent-id)
result))))
@ -154,12 +169,12 @@
(defn hidden-parent?
"Checks the parent for the hidden property"
[objects shape-id]
(let [parent-id (dm/get-in objects [shape-id :parent-id])]
(cond
(or (nil? parent-id) (nil? shape-id) (= shape-id uuid/zero) (= parent-id uuid/zero)) false
(dm/get-in objects [parent-id :hidden]) true
:else
(recur objects parent-id))))
(let [parent-id (get-parent-id objects shape-id)]
(if (or (nil? parent-id) (nil? shape-id) (= shape-id uuid/zero) (= parent-id uuid/zero))
false
(if ^boolean (dm/get-in objects [parent-id :hidden])
true
(recur objects parent-id)))))
(defn get-parent-ids-with-index
"Returns a tuple with the list of parents and a map with the position within each parent"
@ -167,10 +182,10 @@
(loop [parent-list []
parent-indices {}
current shape-id]
(let [parent-id (dm/get-in objects [current :parent-id])
parent (get objects parent-id)]
(let [parent-id (get-parent-id objects current)
parent (get objects parent-id)]
(if (and (some? parent) (not= parent-id current))
(let [parent-list (conj parent-list parent-id)
(let [parent-list (conj parent-list parent-id)
parent-indices (assoc parent-indices parent-id (d/index-of (:shapes parent) current))]
(recur parent-list parent-indices parent-id))
[parent-list parent-indices]))))
@ -178,7 +193,7 @@
(defn get-siblings-ids
[objects id]
(let [parent (get-parent objects id)]
(into [] (->> (:shapes parent) (remove #(= % id))))))
(into [] (remove #(= % id)) (:shapes parent))))
(defn get-frame
"Get the frame that contains the shape. If the shape is already a
@ -190,7 +205,7 @@
(map? shape-or-id)
(if (frame-shape? shape-or-id)
shape-or-id
(get objects (:frame-id shape-or-id)))
(get objects (dm/get-prop shape-or-id :frame-id)))
(= uuid/zero shape-or-id)
(get objects uuid/zero)

9
common/src/app/common/pages/indices.cljc
View File

@ -9,13 +9,6 @@
[app.common.pages.helpers :as cph]
[app.common.uuid :as uuid]))
(defn generate-child-parent-index
[objects]
(reduce-kv
(fn [index id obj]
(assoc index id (:parent-id obj)))
{} objects))
(defn generate-child-all-parents-index
"Creates an index where the key is the shape id and the value is a set
with all the parents"
@ -42,7 +35,7 @@
(not= uuid/zero (:id shape)))
(conj shape)
(:masked-group? shape)
(:masked-group shape)
(conj (get objects (->> shape :shapes first)))
(= :bool (:type shape))

10
common/src/app/common/path/bool.cljc
View File

@ -8,8 +8,8 @@
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes.path :as gsp]
[app.common.geom.shapes.rect :as gpr]
[app.common.path.commands :as upc]
[app.common.path.subpaths :as ups]))
@ -101,7 +101,7 @@
(if (= :move-to (:command segment))
false
(let [r1 (command->selrect segment)]
(gpr/overlaps-rects? r1 selrect))))
(grc/overlaps-rects? r1 selrect))))
(overlap-segments?
[seg-1 seg-2]
@ -110,7 +110,7 @@
false
(let [r1 (command->selrect seg-1)
r2 (command->selrect seg-2)]
(gpr/overlaps-rects? r1 r2))))
(grc/overlaps-rects? r1 r2))))
(split
[seg-1 seg-2]
@ -156,7 +156,7 @@
:curve-to (-> (gsp/command->bezier segment)
(gsp/curve-values 0.5)))]
(and (gpr/contains-point? content-sr point)
(and (grc/contains-point? content-sr point)
(or
(gsp/is-point-in-geom-data? point content-geom)
(gsp/is-point-in-border? point content)))))
@ -170,7 +170,7 @@
:curve-to (-> (gsp/command->bezier segment)
(gsp/curve-values 0.5)))]
(and (gpr/contains-point? content-sr point)
(and (grc/contains-point? content-sr point)
(gsp/is-point-in-geom-data? point content-geom))))
(defn overlap-segment?

4
common/src/app/common/path/shapes_to_path.cljc
View File

@ -10,7 +10,7 @@
[app.common.data :as d]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.common :as gsc]
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.corners :as gso]
[app.common.geom.shapes.path :as gsp]
[app.common.path.bool :as pb]
@ -231,7 +231,7 @@
new-content (cond-> new-content
(some? transform)
(gsp/transform-content (gmt/transform-in (gsc/center-shape shape) transform)))]
(gsp/transform-content (gmt/transform-in (gco/shape->center shape) transform)))]
(-> shape
(assoc :type :path)

267
common/src/app/common/record.cljc Normal file
View File

@ -0,0 +1,267 @@
;; 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) KALEIDOS INC
(ns app.common.record
"A collection of helpers and macros for defien a penpot customized record types."
(:refer-clojure :exclude [defrecord assoc! clone])
#?(:cljs (:require-macros [app.common.record])))
#_:clj-kondo/ignore
(defmacro caching-hash
[coll hash-fn hash-key]
`(let [h# ~hash-key]
(if-not (nil? h#)
h#
(let [h# (~hash-fn ~coll)]
(set! ~hash-key h#)
h#))))
#?(:clj
(defn- property-symbol
[sym]
(symbol (str "-" (name sym)))))
#?(:clj
(defn- generate-field-access
[this-sym val-sym fields]
(map (fn [field]
(cond
(nil? field) nil
(identical? field val-sym) val-sym
:else `(. ~this-sym ~(property-symbol field))))
fields)))
#?(:clj
(defn emit-extend
[env tagname fields impls]
(let [base-fields (mapv #(with-meta % nil) fields)
fields (conj base-fields '$meta '$extmap (with-meta '$hash {:mutable true}))
key-sym (gensym "key-")
val-sym (gensym "val-")
this-sym (with-meta (gensym "this-") {:tag tagname})
other-sym (gensym "other-")
pr-open (str "#" (-> env :ns :name) "." (name tagname) "{")]
(concat impls
['cljs.core/ICloneable
`(~'-clone [~this-sym]
(new ~tagname ~@(generate-field-access this-sym val-sym fields)))
'IHash
`(~'-hash [~this-sym]
(caching-hash ~this-sym
(fn [coll#]
(bit-xor
~(hash (str tagname))
(cljs.core/hash-unordered-coll coll#)))
(. ~this-sym ~'-$hash)))
'cljs.core/IEquiv
`(~'-equiv [~this-sym ~other-sym]
(and (some? ~other-sym)
(identical? (.-constructor ~this-sym)
(.-constructor ~other-sym))
~@(map (fn [field]
`(= (.. ~this-sym ~(property-symbol field))
(.. ~(with-meta other-sym {:tag tagname}) ~(property-symbol field))))
base-fields)
(= (. ~this-sym ~'-$extmap)
(. ~(with-meta other-sym {:tag tagname}) ~'-$extmap))))
'cljs.core/IMeta
`(~'-meta [~this-sym] (. ~this-sym ~'-$meta))
'cljs.core/IWithMeta
`(~'-with-meta [~this-sym ~val-sym]
(new ~tagname ~@(->> (replace {'$meta val-sym} fields)
(generate-field-access this-sym val-sym))))
'cljs.core/ILookup
`(~'-lookup
([~this-sym k#]
(cljs.core/-lookup ~this-sym k# nil))
([~this-sym ~key-sym else#]
(case ~key-sym
~@(mapcat (fn [f] [(keyword f) `(. ~this-sym ~(property-symbol f))])
base-fields)
(cljs.core/get (. ~this-sym ~'-$extmap) ~key-sym else#))))
'cljs.core/ICounted
`(~'-count [~this-sym]
(+ ~(count base-fields) (count (. ~this-sym ~'-$extmap))))
'cljs.core/ICollection
`(~'-conj [~this-sym ~val-sym]
(if (vector? ~val-sym)
(cljs.core/-assoc ~this-sym (cljs.core/-nth ~val-sym 0) (cljs.core/-nth ~val-sym 1))
(reduce cljs.core/-conj ~this-sym ~val-sym)))
'cljs.core/IAssociative
`(~'-contains-key? [~this-sym ~key-sym]
~(if (seq base-fields)
`(case ~key-sym
(~@(map keyword base-fields)) true
(contains? (. ~this-sym ~'-$extmap) ~key-sym))
`(contains? (. ~this-sym ~'-$extmap) ~key-sym)))
`(~'-assoc [~this-sym ~key-sym ~val-sym]
(case ~key-sym
~@(mapcat (fn [fld]
[(keyword fld) `(new ~tagname ~@(->> (replace {fld val-sym '$hash nil} fields)
(generate-field-access this-sym val-sym)))])
base-fields)
(new ~tagname ~@(->> (remove #{'$extmap '$hash} fields)
(generate-field-access this-sym val-sym))
(assoc (. ~this-sym ~'-$extmap) ~key-sym ~val-sym) nil)))
'cljs.core/ITransientAssociative
`(~'-assoc! [~this-sym ~key-sym ~val-sym]
(let [key# (if (keyword? ~key-sym)
(.-fqn ~(with-meta key-sym {:tag `cljs.core/Keyword}))
~key-sym)]
(case ~key-sym
~@(mapcat
(fn [f]
[(keyword f) `(set! (. ~this-sym ~(property-symbol f)) ~val-sym)])
base-fields)
(set! (. ~this-sym ~'-$extmap) (cljs.core/assoc (. ~this-sym ~'-$extmap) ~key-sym ~val-sym)))
~this-sym))
'cljs.core/IMap
`(~'-dissoc [~this-sym ~key-sym]
(case ~key-sym
(~@(map keyword base-fields))
(cljs.core/-assoc ~this-sym ~key-sym nil)
(let [extmap1# (. ~this-sym ~'-$extmap)
extmap2# (dissoc extmap1# ~key-sym)]
(if (identical? extmap1# extmap2#)
~this-sym
(new ~tagname ~@(->> (remove #{'$extmap '$hash} fields)
(generate-field-access this-sym val-sym))
(not-empty extmap2#)
nil)))))
'cljs.core/ISeqable
`(~'-seq [~this-sym]
(seq (concat [~@(map (fn [f]
`(cljs.core/MapEntry.
~(keyword f)
(. ~this-sym ~(property-symbol f))
nil))
base-fields)]
(. ~this-sym ~'-$extmap))))
'cljs.core/IIterable
`(~'-iterator [~this-sym]
(cljs.core/RecordIter. 0 ~this-sym ~(count base-fields)
[~@(map keyword base-fields)]
(if (. ~this-sym ~'-$extmap)
(cljs.core/-iterator (. ~this-sym ~'-$extmap))
(cljs.core/nil-iter))))
'cljs.core/IKVReduce
`(~'-kv-reduce [~this-sym f# init#]
(reduce (fn [ret# [~key-sym v#]] (f# ret# ~key-sym v#)) init# ~this-sym))
'cljs.core/IPrintWithWriter
`(~'-pr-writer [~this-sym writer# opts#]
(let [pr-pair# (fn [keyval#]
(cljs.core/pr-sequential-writer writer# (~'js* "cljs.core.pr_writer")
"" " " "" opts# keyval#))]
(cljs.core/pr-sequential-writer
writer# pr-pair# ~pr-open ", " "}" opts#
(concat [~@(for [f base-fields]
`(vector ~(keyword f) (. ~this-sym ~(property-symbol f))))]
(. ~this-sym ~'-$extmap)))))
]))))
(defmacro defrecord
[rsym fields & impls]
(let [param (gensym "param-")
ks (map keyword fields)]
(if (:ns &env)
`(do
(deftype ~rsym ~(into fields ['$meta '$extmap '$hash]))
(extend-type ~rsym ~@(emit-extend &env rsym fields impls))
(defn ~(with-meta (symbol (str "pos->" rsym))
(assoc (meta rsym) :factory :positional))
[~@fields]
(new ~rsym ~@(conj fields nil nil nil)))
(defn ~(with-meta (symbol (str 'map-> rsym))
(assoc (meta rsym) :factory :map))
[~param]
(let [exclude# #{~@ks}
extmap# (reduce-kv (fn [acc# k# v#]
(if (contains? exclude# k#)
acc#
(assoc acc# k# v#)))
{}
~param)]
(new ~rsym
~@(for [k ks]
`(get ~param ~k))
nil
(not-empty extmap#)
nil)))
~rsym)
`(do
(clojure.core/defrecord ~rsym ~fields ~@impls)
(defn ~(with-meta (symbol (str "pos->" rsym))
(assoc (meta rsym) :factory :positional))
[~@(map (fn [f] (vary-meta f dissoc :tag)) fields)]
(new ~rsym ~@(conj fields nil nil)))))))
(defmacro clone
[ssym]
(if (:ns &env)
`(cljs.core/clone ~ssym)
ssym))
(defmacro assoc!
"A record specific update operation"
[ssym & pairs]
(if (:ns &env)
(let [pairs (partition-all 2 pairs)]
`(-> ~ssym
~@(map (fn [[ks vs]]
`(cljs.core/-assoc! ~ks ~vs))
pairs)))
`(assoc ~ssym ~@pairs)))
(defmacro update!
"A record specific update operation"
[ssym ksym f & params]
(if (:ns &env)
(let [ssym (with-meta ssym {:tag 'js})]
`(cljs.core/assoc! ~ssym ~ksym (~f (. ~ssym ~(property-symbol ksym)) ~@params)))
`(update ~ssym ~ksym ~f ~@params)))
(defmacro define-properties!
[rsym & properties]
(let [rsym (with-meta rsym {:tag 'js})]
`(do
~@(for [params properties
:let [pname (get params :name)
get-fn (get params :get)
set-fn (get params :set)]]
`(.defineProperty js/Object
(.-prototype ~rsym)
~pname
(cljs.core/js-obj
"enumerable" true
"configurable" true
~@(concat
(when get-fn
["get" get-fn])
(when set-fn
["set" set-fn]))))))))

1
common/src/app/common/schema/generators.cljc
View File

@ -82,7 +82,6 @@
ext (tg/elements ["net" "com" "org" "app" "io"])]
(u/uri (str scheme "://" domain "." ext))))
;; FIXME: revisit
(defn uuid
[]
(->> tg/small-integer

21
common/src/app/common/transit.cljc
View File

@ -7,8 +7,6 @@
(ns app.common.transit
(:require
[app.common.data :as d]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.uri :as uri]
[cognitect.transit :as t]
[lambdaisland.uri :as luri]
@ -18,8 +16,6 @@
#?(:cljs ["luxon" :as lxn]))
#?(:clj
(:import
app.common.geom.matrix.Matrix
app.common.geom.point.Point
java.io.ByteArrayInputStream
java.io.ByteArrayOutputStream
java.io.File
@ -122,23 +118,6 @@
{:id "u"
:rfn parse-uuid})
{:id "point"
:class #?(:clj Point :cljs gpt/Point)
:wfn #(into {} %)
:rfn gpt/map->Point}
{:id "matrix"
:class #?(:clj Matrix :cljs gmt/Matrix)
:wfn #(into {} %)
:rfn #?(:cljs gmt/map->Matrix
:clj (fn [{:keys [a b c d e f]}]
(gmt/matrix (double a)
(double b)
(double c)
(double d)
(double e)
(double f))))}
{:id "ordered-set"
:class #?(:clj LinkedSet :cljs lks/LinkedSet)
:wfn vec

100
common/src/app/common/types/component.cljc
View File

@ -6,10 +6,97 @@
(ns app.common.types.component)
;; Attributes that may be synced in components, and the group they belong to.
;; When one attribute is modified in a shape inside a component, the corresponding
;; group is marked as :touched. Then, if the shape is synced with the remote shape
;; in the main component, none of the attributes of the same group is changed.
(def sync-attrs
{:name :name-group
:fills :fill-group
:hide-fill-on-export :fill-group
:content :content-group
:position-data :content-group
:hidden :visibility-group
:blocked :modifiable-group
:grow-type :text-font-group
:font-family :text-font-group
:font-size :text-font-group
:font-style :text-font-group
:font-weight :text-font-group
:letter-spacing :text-display-group
:line-height :text-display-group
:text-align :text-display-group
:strokes :stroke-group
;; DEPRECATED: FIXME: this attrs are deprecated for a long time but
;; we still have tests that uses this attribute for synchronization
:stroke-width :stroke-group
:fill-color :fill-group
:fill-opacity :fill-group
:rx :radius-group
:ry :radius-group
:r1 :radius-group
:r2 :radius-group
:r3 :radius-group
:r4 :radius-group
:type :geometry-group
:selrect :geometry-group
:points :geometry-group
:locked :geometry-group
:proportion :geometry-group
:proportion-lock :geometry-group
:x :geometry-group
:y :geometry-group
:width :geometry-group
:height :geometry-group
:rotation :geometry-group
:transform :geometry-group
:transform-inverse :geometry-group
:opacity :layer-effects-group
:blend-mode :layer-effects-group
:shadow :shadow-group
:blur :blur-group
:masked-group :mask-group
:constraints-h :constraints-group
:constraints-v :constraints-group
:fixed-scroll :constraints-group
:exports :exports-group
:layout :layout-container
:layout-align-content :layout-container
:layout-align-items :layout-container
:layout-flex-dir :layout-container
:layout-gap :layout-container
:layout-gap-type :layout-container
:layout-justify-content :layout-container
:layout-justify-items :layout-container
:layout-wrap-type :layout-container
:layout-padding-type :layout-container
:layout-padding :layout-container
:layout-h-orientation :layout-container
:layout-v-orientation :layout-container
:layout-grid-dir :layout-container
:layout-grid-rows :layout-container
:layout-grid-columns :layout-container
:layout-grid-cells :layout-container
:layout-item-margin :layout-item
:layout-item-margin-type :layout-item
:layout-item-h-sizing :layout-item
:layout-item-v-sizing :layout-item
:layout-item-max-h :layout-item
:layout-item-min-h :layout-item
:layout-item-max-w :layout-item
:layout-item-min-w :layout-item
:layout-item-align-self :layout-item})
(defn instance-root?
"Check if this shape is the head of a top instance."
[shape]
(some? (:component-root? shape)))
(some? (:component-root shape)))
(defn instance-head?
"Check if this shape is the head of a top instance or a subinstance."
@ -36,9 +123,10 @@
(= (:shape-ref shape-inst) (:shape-ref shape-main)))))
(defn main-instance?
"Check if this shape is the root of the main instance of some component."
"Check if this shape is the root of the main instance of some
component."
[shape]
(some? (:main-instance? shape)))
(some? (:main-instance shape)))
(defn in-component-copy?
"Check if the shape is inside a component non-main instance."
@ -63,7 +151,7 @@
(if (some? (:main-instance-id component))
(get-in component [:objects (:main-instance-id component)])
(get-in component [:objects (:id component)])))
(defn uses-library-components?
"Check if the shape uses any component in the given library."
[shape library-id]
@ -76,7 +164,7 @@
(dissoc shape
:component-id
:component-file
:component-root?
:remote-synced?
:component-root
:remote-synced
:shape-ref
:touched))

36
common/src/app/common/types/container.cljc
View File

@ -7,9 +7,10 @@
(ns app.common.types.container
(:require
[app.common.data.macros :as dm]
[app.common.files.helpers :as cfh]
[app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh]
[app.common.pages.common :as common]
[app.common.pages.helpers :as cph]
[app.common.schema :as sm]
[app.common.types.component :as ctk]
[app.common.types.components-list :as ctkl]
@ -100,7 +101,7 @@
(nil? shape)
nil
(= uuid/zero (:id shape))
(cph/root-frame? shape)
nil
(and (not (ctk/in-component-copy? shape)) (not allow-main?))
@ -119,7 +120,7 @@
a main component have not any discriminating attribute."
[objects shape]
(let [component-shape (get-component-shape objects shape {:allow-main? true})]
(:main-instance? component-shape)))
(:main-instance component-shape)))
(defn in-any-component?
"Check if the shape is part of any component (main or copy), wether it's
@ -146,7 +147,7 @@
(cond-> new-shape
true
(dissoc :component-root?)
(dissoc :component-root)
(nil? (:parent-id new-shape))
(dissoc :component-id
@ -165,13 +166,13 @@
(nil? (:parent-id new-shape))
(assoc :component-id (:id new-shape)
:component-file file-id
:component-root? true)
:component-root true)
(and (nil? (:parent-id new-shape)) components-v2)
(assoc :main-instance? true)
(assoc :main-instance true)
(some? (:parent-id new-shape))
(dissoc :component-root?)))
(dissoc :component-root)))
[new-root-shape new-shapes updated-shapes]
(ctst/clone-object shape nil objects update-new-shape update-original-shape)
@ -186,9 +187,10 @@
(defn make-component-instance
"Generate a new instance of the component inside the given container.
Clone the shapes of the component, generating new names and ids, and linking
each new shape to the corresponding one of the component. Place the new instance
coordinates in the given position."
Clone the shapes of the component, generating new names and ids, and
linking each new shape to the corresponding one of the
component. Place the new instance coordinates in the given
position."
([container component library-data position components-v2]
(make-component-instance container component library-data position components-v2 {}))
@ -197,17 +199,19 @@
:or {main-instance? false force-id nil force-frame-id nil keep-ids? false}}]
(let [component-page (when components-v2
(ctpl/get-page library-data (:main-instance-page component)))
component-shape (if components-v2
(-> (get-shape component-page (:main-instance-id component))
(assoc :parent-id nil)
(assoc :frame-id uuid/zero))
(get-shape component (:id component)))
orig-pos (gpt/point (:x component-shape) (:y component-shape))
delta (gpt/subtract position orig-pos)
objects (:objects container)
unames (volatile! (common/retrieve-used-names objects))
unames (volatile! (cfh/get-used-names objects))
frame-id (or force-frame-id
(ctst/frame-id-by-position objects
@ -231,10 +235,10 @@
(dissoc :touched))
main-instance?
(assoc :main-instance? true)
(assoc :main-instance true)
(not main-instance?)
(dissoc :main-instance?)
(dissoc :main-instance)
(and (not main-instance?) (nil? (:shape-ref original-shape)))
(assoc :shape-ref (:id original-shape))
@ -242,14 +246,14 @@
(nil? (:parent-id original-shape))
(assoc :component-id (:id component)
:component-file (:id library-data)
:component-root? true
:component-root true
:name new-name)
(and (nil? (:parent-id original-shape)) main-instance? components-v2)
(assoc :main-instance? true)
(assoc :main-instance true)
(some? (:parent-id original-shape))
(dissoc :component-root?))))
(dissoc :component-root))))
[new-shape new-shapes _]
(ctst/clone-object component-shape

28
common/src/app/common/types/file.cljc
View File

@ -8,10 +8,10 @@
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.files.defaults :refer [version]]
[app.common.files.features :as ffeat]
[app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh]
[app.common.pages.common :refer [file-version]]
[app.common.pages.helpers :as cph]
[app.common.schema :as sm]
[app.common.types.color :as ctc]
@ -68,7 +68,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def empty-file-data
{:version file-version
{:version version
:pages []
:pages-index {}})
@ -79,9 +79,8 @@
([file-id page-id]
(let [page (when (some? page-id)
(ctp/make-empty-page page-id "Page 1"))]
(cond-> (-> empty-file-data
(assoc :id file-id))
(cond-> (assoc empty-file-data :id file-id)
(some? page-id)
(ctpl/add-page page)
@ -291,7 +290,7 @@
been modified after the given date."
[file-data library since-date]
(letfn [(used-assets-shape [shape]
(concat
(concat
(ctkl/used-components-changed-since shape library since-date)
(ctcl/used-colors-changed-since shape library since-date)
(ctyl/used-typographies-changed-since shape library since-date)))
@ -299,7 +298,7 @@
(used-assets-container [container]
(->> (mapcat used-assets-shape (ctn/shapes-seq container))
(map #(cons (:id container) %))))]
(mapcat used-assets-container (containers-seq file-data))))
(defn get-or-add-library-page
@ -347,7 +346,7 @@
file-data
position
false
{:main-instance? true
{:main-instance true
:force-frame-id uuid/zero
:keep-ids? true})
add-shapes
@ -430,7 +429,7 @@
library-data
position
(dm/get-in file-data [:options :components-v2])
{:main-instance? true})
{:main-instance true})
main-instance-shapes
(map #(cond-> %
@ -590,9 +589,9 @@
(letfn [(show-shape [shape-id level objects]
(let [shape (get objects shape-id)]
(println (str/pad (str (str/repeat " " level)
(when (:main-instance? shape) "{")
(when (:main-instance shape) "{")
(:name shape)
(when (:main-instance? shape) "}")
(when (:main-instance shape) "}")
(when (seq (:touched shape)) "*")
(when show-ids (str/format " <%s>" (:id shape))))
{:length 20
@ -603,7 +602,7 @@
(println (str (str/repeat " " level)
" "
(str (:touched shape)))))
(when (:remote-synced? shape)
(when (:remote-synced shape)
(println (str (str/repeat " " level)
" (remote-synced)"))))
(when (:shapes shape)
@ -612,7 +611,7 @@
(show-component-info [shape objects]
(if (nil? (:shape-ref shape))
(if (:component-root? shape) " #" "")
(if (:component-root shape) " #" "")
(let [root-shape (ctn/get-component-shape objects shape)
component-id (when root-shape (:component-id root-shape))
component-file-id (when root-shape (:component-file root-shape))
@ -627,7 +626,7 @@
(get-ref-shape file-data component shape)))]
(str/format " %s--> %s%s%s"
(cond (:component-root? shape) "#"
(cond (:component-root shape) "#"
(:component-id shape) "@"
:else "-")
@ -635,7 +634,7 @@
(or (:name component-shape) "?")
(if (or (:component-root? shape)
(if (or (:component-root shape)
(nil? (:component-id shape))
true)
""
@ -672,4 +671,3 @@
(show-shape (:id component) 0 (:objects component)))
(when (:main-instance-page component)
(show-component-instance component)))))))))

124
common/src/app/common/types/modifiers.cljc
View File

@ -19,8 +19,7 @@
[app.common.pages.helpers :as cph]
[app.common.text :as txt]
[app.common.types.shape.layout :as ctl]
#?(:cljs [cljs.core :as c]
:clj [clojure.core :as c])))
[clojure.core :as c]))
;; --- Modifiers
@ -106,18 +105,17 @@
[property value]
(StructureOperation. :change-property property value nil))
;; Private aux functions
(defn- move-vec?
[vector]
(or (not (mth/almost-zero? (dm/get-prop vector :x)))
(not (mth/almost-zero? (dm/get-prop vector :y)))))
(or (not ^boolean (mth/almost-zero? (dm/get-prop vector :x)))
(not ^boolean (mth/almost-zero? (dm/get-prop vector :y)))))
(defn- resize-vec?
[vector]
(or (not (mth/almost-zero? (- (dm/get-prop vector :x) 1)))
(not (mth/almost-zero? (- (dm/get-prop vector :y) 1)))))
(or (not ^boolean (mth/almost-zero? (- (dm/get-prop vector :x) 1)))
(not ^boolean (mth/almost-zero? (- (dm/get-prop vector :y) 1)))))
(defn- mergeable-move?
[op1 op2]
@ -128,22 +126,24 @@
(defn- mergeable-resize?
[op1 op2]
(let [type-op1 (dm/get-prop op1 :type)
transform-op1 (or (dm/get-prop op1 :transform) (gmt/matrix))
transform-inv-op1 (or (dm/get-prop op1 :transform-inverse) (gmt/matrix))
transform-op1 (d/nilv (dm/get-prop op1 :transform) gmt/base)
transform-inv-op1 (d/nilv (dm/get-prop op1 :transform-inverse) gmt/base)
origin-op1 (dm/get-prop op1 :origin)
type-op2 (dm/get-prop op2 :type)
transform-op2 (or (dm/get-prop op2 :transform) (gmt/matrix))
transform-inv-op2 (or (dm/get-prop op2 :transform-inverse) (gmt/matrix))
transform-op2 (d/nilv (dm/get-prop op2 :transform) gmt/base)
transform-inv-op2 (d/nilv (dm/get-prop op2 :transform-inverse) gmt/base)
origin-op2 (dm/get-prop op2 :origin)]
(and (= :resize type-op1) (= :resize type-op2)
(and (= :resize type-op1)
(= :resize type-op2)
;; Same origin
(gpt/close? origin-op1 origin-op2)
^boolean (gpt/close? origin-op1 origin-op2)
;; Same transforms
(gmt/close? transform-op1 transform-op2)
(gmt/close? transform-inv-op1 transform-inv-op2))))
^boolean (gmt/close? transform-op1 transform-op2)
^boolean (gmt/close? transform-inv-op1 transform-inv-op2))))
(defn- merge-move
[op1 op2]
@ -155,14 +155,15 @@
(defn- merge-resize
[op1 op2]
(let [op1-vector (dm/get-prop op1 :vector)
op1-x (dm/get-prop op1-vector :x)
op1-y (dm/get-prop op1-vector :y)
op1-x (dm/get-prop op1-vector :x)
op1-y (dm/get-prop op1-vector :y)
op2-vector (dm/get-prop op2 :vector)
op2-x (dm/get-prop op2-vector :x)
op2-y (dm/get-prop op2-vector :y)
op2-x (dm/get-prop op2-vector :x)
op2-y (dm/get-prop op2-vector :y)
vector (gpt/point (* op1-x op2-x) (* op1-y op2-y))]
vector (gpt/point (* op1-x op2-x)
(* op1-y op2-y))]
(assoc op1 :vector vector)))
(defn- maybe-add-move
@ -198,10 +199,7 @@
[vector]
(let [x (dm/get-prop vector :x)
y (dm/get-prop vector :y)]
(and (some? x)
(some? y)
(not (mth/nan? x))
(not (mth/nan? y)))))
(d/num? x y)))
;; Public builder API
@ -245,8 +243,11 @@
(move modifiers (gpt/point x y)))
([modifiers vector]
(assert (valid-vector? vector) (dm/str "Invalid move vector: " (:x vector) "," (:y vector)))
(let [modifiers (or modifiers (empty))
(dm/assert!
["Invalid move vector: %1,%2" (:x vector) (:y vector)]
(valid-vector? vector))
(let [modifiers (or ^boolean modifiers (empty))
order (inc (dm/get-prop modifiers :last-order))
modifiers (assoc modifiers :last-order order)]
(cond-> modifiers
@ -256,7 +257,7 @@
(defn resize
([modifiers vector origin]
(assert (valid-vector? vector) (dm/str "Invalid resize vector: " (:x vector) "," (:y vector)))
(let [modifiers (or modifiers (empty))
(let [modifiers (or ^boolean modifiers (empty))
order (inc (dm/get-prop modifiers :last-order))
modifiers (assoc modifiers :last-order order)]
(cond-> modifiers
@ -412,7 +413,7 @@
(defn rotation-modifiers
[shape center angle]
(let [shape-center (gco/center-shape shape)
(let [shape-center (gco/shape->center shape)
;; Translation caused by the rotation
move-vec
(gpt/transform
@ -502,7 +503,7 @@
shape-transform (:transform shape)
shape-transform-inv (:transform-inverse shape)
shape-center (gco/center-shape shape)
shape-center (gco/shape->center shape)
{sr-width :width sr-height :height} (:selrect shape)
origin (cond-> (gpt/point (:selrect shape))
@ -594,7 +595,72 @@
;; Main transformation functions
(defn transform-move!
"Transforms a matrix by the translation modifier"
[matrix modifier]
(-> (dm/get-prop modifier :vector)
(gmt/translate-matrix)
(gmt/multiply! matrix)))
(defn transform-resize!
"Transforms a matrix by the resize modifier"
[matrix modifier]
(let [tf (dm/get-prop modifier :transform)
tfi (dm/get-prop modifier :transform-inverse)
vector (dm/get-prop modifier :vector)
origin (dm/get-prop modifier :origin)
origin (if ^boolean (some? tfi)
(gpt/transform origin tfi)
origin)]
(gmt/multiply!
(-> (gmt/matrix)
(cond-> ^boolean (some? tf)
(gmt/multiply! tf))
(gmt/translate! origin)
(gmt/scale! vector)
(gmt/translate! (gpt/negate origin))
(cond-> ^boolean (some? tfi)
(gmt/multiply! tfi)))
matrix)))
(defn transform-rotate!
"Transforms a matrix by the rotation modifier"
[matrix modifier]
(let [center (dm/get-prop modifier :center)
rotation (dm/get-prop modifier :rotation)]
(gmt/multiply!
(-> (gmt/matrix)
(gmt/translate! center)
(gmt/multiply! (gmt/rotate-matrix rotation))
(gmt/translate! (gpt/negate center)))
matrix)))
(defn transform!
"Returns a matrix transformed by the modifier"
[matrix modifier]
(let [type (dm/get-prop modifier :type)]
(case type
:move (transform-move! matrix modifier)
:resize (transform-resize! matrix modifier)
:rotation (transform-rotate! matrix modifier))))
(defn modifiers->transform1
"A multiplatform version of modifiers->transform."
[modifiers]
(reduce transform! (gmt/matrix) modifiers))
(defn modifiers->transform
"Given a set of modifiers returns its transformation matrix"
[modifiers]
(let [modifiers (concat (dm/get-prop modifiers :geometry-parent)
(dm/get-prop modifiers :geometry-child))
modifiers (sort-by #(dm/get-prop % :order) modifiers)
]
(modifiers->transform1 modifiers)))
(defn modifiers->transform-old
"Given a set of modifiers returns its transformation matrix"
[modifiers]
(let [modifiers (->> (concat (dm/get-prop modifiers :geometry-parent)

8
common/src/app/common/types/page.cljc
View File

@ -66,9 +66,11 @@
(def empty-page-data
{:options {}
:objects {root
{:id root
:type :frame
:name "Root Frame"}}})
(cts/setup-shape {:id root
:type :frame
:parent-id root
:frame-id root
:name "Root Frame"})}})
(defn make-empty-page
[id name]

367
common/src/app/common/types/shape.cljc
View File

@ -6,16 +6,21 @@
(ns app.common.types.shape
(:require
#?(:clj [app.common.fressian :as fres])
[app.common.colors :as clr]
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.proportions :as gpr]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.pages.common :refer [default-color]]
[app.common.record :as cr]
[app.common.schema :as sm]
[app.common.schema.generators :as sg]
[app.common.transit :as t]
[app.common.types.color :as ctc]
[app.common.types.grid :as ctg]
[app.common.types.shape.attrs :refer [default-color]]
[app.common.types.shape.blur :as ctsb]
[app.common.types.shape.export :as ctse]
[app.common.types.shape.interactions :as ctsi]
@ -25,10 +30,26 @@
[app.common.uuid :as uuid]
[clojure.set :as set]))
(cr/defrecord Shape [id name type x y width height rotation selrect points transform transform-inverse parent-id frame-id])
(defn shape?
[o]
(instance? Shape o))
(def stroke-caps-line #{:round :square})
(def stroke-caps-marker #{:line-arrow :triangle-arrow :square-marker :circle-marker :diamond-marker})
(def stroke-caps (set/union stroke-caps-line stroke-caps-marker))
(def shape-types
#{:frame
:group
:bool
:rect
:path
:circle
:svg-raw
:image})
(def blend-modes
#{:normal
:darken
@ -57,18 +78,26 @@
#{"left" "right" "center" "justify"})
(sm/def! ::selrect
[:map {:title "Selrect"}
[:x ::sm/safe-number]
[:y ::sm/safe-number]
[:x1 ::sm/safe-number]
[:x2 ::sm/safe-number]
[:y1 ::sm/safe-number]
[:y2 ::sm/safe-number]
[:width ::sm/safe-number]
[:height ::sm/safe-number]])
[:and
{:title "Selrect"
:gen/gen (->> (sg/tuple (sg/small-double)
(sg/small-double)
(sg/small-double)
(sg/small-double))
(sg/fmap #(apply grc/make-rect %)))}
[:fn grc/rect?]
[:map
[:x ::sm/safe-number]
[:y ::sm/safe-number]
[:x1 ::sm/safe-number]
[:x2 ::sm/safe-number]
[:y1 ::sm/safe-number]
[:y2 ::sm/safe-number]
[:width ::sm/safe-number]
[:height ::sm/safe-number]]])
(sm/def! ::points
[:vector {:gen/max 5} ::gpt/point])
[:vector {:gen/max 4 :gen/min 4} ::gpt/point])
(sm/def! ::fill
[:map {:title "Fill" :min 1}
@ -95,12 +124,30 @@
[::sm/one-of stroke-caps]]
[:stroke-color-gradient {:optional true} ::ctc/gradient]])
(sm/def! ::minimal-shape-attrs
[:map {:title "ShapeMinimalRecord"}
[:id {:optional false} ::sm/uuid]
[:name {:optional false} :string]
[:type {:optional false} [::sm/one-of shape-types]]
[:x {:optional false} [:maybe ::sm/safe-number]]
[:y {:optional false} [:maybe ::sm/safe-number]]
[:width {:optional false} [:maybe ::sm/safe-number]]
[:height {:optional false} [:maybe ::sm/safe-number]]
[:selrect {:optional false} ::selrect]
[:points {:optional false} ::points]
[:transform {:optional false} ::gmt/matrix]
[:transform-inverse {:optional false} ::gmt/matrix]
[:parent-id {:optional false} ::sm/uuid]
[:frame-id {:optional false} ::sm/uuid]])
(sm/def! ::shape-attrs
[:map {:title "ShapeAttrs"}
[:name {:optional true} :string]
[:component-id {:optional true} ::sm/uuid]
[:component-file {:optional true} ::sm/uuid]
[:component-root {:optional true} :boolean]
[:main-instance {:optional true} :boolean]
[:remote-synced {:optional true} :boolean]
[:shape-ref {:optional true} ::sm/uuid]
[:selrect {:optional true} ::selrect]
[:points {:optional true} ::points]
@ -108,7 +155,7 @@
[:collapsed {:optional true} :boolean]
[:locked {:optional true} :boolean]
[:hidden {:optional true} :boolean]
[:masked-group? {:optional true} :boolean]
[:masked-group {:optional true} :boolean]
[:fills {:optional true}
[:vector {:gen/max 2} ::fill]]
[:hide-fill-on-export {:optional true} :boolean]
@ -125,10 +172,10 @@
[:r2 {:optional true} ::sm/safe-number]
[:r3 {:optional true} ::sm/safe-number]
[:r4 {:optional true} ::sm/safe-number]
[:x {:optional true} ::sm/safe-number]
[:y {:optional true} ::sm/safe-number]
[:width {:optional true} ::sm/safe-number]
[:height {:optional true} ::sm/safe-number]
[:x {:optional true} [:maybe ::sm/safe-number]]
[:y {:optional true} [:maybe ::sm/safe-number]]
[:width {:optional true} [:maybe ::sm/safe-number]]
[:height {:optional true} [:maybe ::sm/safe-number]]
[:opacity {:optional true} ::sm/safe-number]
[:grids {:optional true}
[:vector {:gen/max 2} ::ctg/grid]]
@ -148,21 +195,18 @@
[::sm/one-of #{:auto-width :auto-height :fixed}]]
])
(def shape-attrs?
(def valid-shape-attrs?
(sm/pred-fn ::shape-attrs))
(sm/def! ::group-attrs
[:map {:title "GroupAttrs"}
[:type [:= :group]]
[:id ::sm/uuid]
[:shapes [:vector {:min 1 :gen/max 10 :gen/min 1} ::sm/uuid]]])
(sm/def! ::frame-attrs
[:map {:title "FrameAttrs"}
[:type [:= :frame]]
[:id ::sm/uuid]
[:shapes {:optional true} [:vector {:gen/max 10 :gen/min 1} ::sm/uuid]]
[:file-thumbnail {:optional true} :boolean]
[:shapes [:vector {:gen/max 10 :gen/min 1} ::sm/uuid]]
[:hide-fill-on-export {:optional true} :boolean]
[:show-content {:optional true} :boolean]
[:hide-in-viewer {:optional true} :boolean]])
@ -170,7 +214,6 @@
(sm/def! ::bool-attrs
[:map {:title "BoolAttrs"}
[:type [:= :bool]]
[:id ::sm/uuid]
[:shapes [:vector {:min 1 :gen/max 10 :gen/min 1} ::sm/uuid]]
;; FIXME: improve this schema
@ -186,23 +229,19 @@
(sm/def! ::rect-attrs
[:map {:title "RectAttrs"}
[:type [:= :rect]]
[:id ::sm/uuid]])
[:type [:= :rect]]])
(sm/def! ::circle-attrs
[:map {:title "CircleAttrs"}
[:type [:= :circle]]
[:id ::sm/uuid]])
[:type [:= :circle]]])
(sm/def! ::svg-raw-attrs
[:map {:title "SvgRawAttrs"}
[:type [:= :svg-raw]]
[:id ::sm/uuid]])
[:type [:= :svg-raw]]])
(sm/def! ::image-attrs
[:map {:title "ImageAttrs"}
[:type [:= :image]]
[:id ::sm/uuid]
[:metadata
[:map
[:width :int]
@ -213,7 +252,6 @@
(sm/def! ::path-attrs
[:map {:title "PathAttrs"}
[:type [:= :path]]
[:id ::sm/uuid]
[:content
[:vector
[:map
@ -222,21 +260,21 @@
(sm/def! ::text-attrs
[:map {:title "TextAttrs"}
[:id ::sm/uuid]
[:type [:= :text]]
[:content {:optional true} [:maybe ::ctsx/content]]])
(sm/def! ::shape
(sm/def! ::shape-map
[:multi {:dispatch :type :title "Shape"}
[:group
[:merge {:title "GroupShape"}
::shape-attrs
::minimal-shape-attrs
::group-attrs
::ctsl/layout-child-attrs]]
[:frame
[:merge {:title "FrameShape"}
::shape-attrs
::minimal-shape-attrs
::frame-attrs
::ctsl/layout-attrs
::ctsl/layout-child-attrs]]
@ -244,196 +282,219 @@
[:bool
[:merge {:title "BoolShape"}
::shape-attrs
::minimal-shape-attrs
::bool-attrs
::ctsl/layout-child-attrs]]
[:rect
[:merge {:title "RectShape"}
::shape-attrs
::minimal-shape-attrs
::rect-attrs
::ctsl/layout-child-attrs]]
[:circle
[:merge {:title "CircleShape"}
::shape-attrs
::minimal-shape-attrs
::circle-attrs
::ctsl/layout-child-attrs]]
[:image
[:merge {:title "ImageShape"}
::shape-attrs
::minimal-shape-attrs
::image-attrs
::ctsl/layout-child-attrs]]
[:svg-raw
[:merge {:title "SvgRawShape"}
::shape-attrs
::minimal-shape-attrs
::svg-raw-attrs
::ctsl/layout-child-attrs]]
[:path
[:merge {:title "PathShape"}
::shape-attrs
::minimal-shape-attrs
::path-attrs
::ctsl/layout-child-attrs]]
[:text
[:merge {:title "TextShape"}
::shape-attrs
::minimal-shape-attrs
::text-attrs
::ctsl/layout-child-attrs]]])
(def shape?
(sm/def! ::shape
[:and
{:title "Shape"
:gen/gen (->> (sg/generator ::shape-map)
(sg/fmap map->Shape))}
::shape-map
[:fn shape?]])
(def valid-shape?
(sm/pred-fn ::shape))
;; --- Initialization
(def default-shape-attrs
{})
(def ^:private minimal-rect-attrs
{:type :rect
:name "Rectangle"
:fills [{:fill-color default-color
:fill-opacity 1}]
:strokes []
:rx 0
:ry 0})
(def default-frame-attrs
(def ^:private minimal-image-attrs
{:type :image
:rx 0
:ry 0
:fills []
:strokes []})
(def ^:private minimal-frame-attrs
{:frame-id uuid/zero
:fills [{:fill-color clr/white
:fill-opacity 1}]
:name "Board"
:strokes []
:shapes []
:hide-fill-on-export false})
(def ^:private minimal-shapes
[{:type :rect
:name "Rectangle"
:fills [{:fill-color default-color
:fill-opacity 1}]
:strokes []
:rx 0
:ry 0}
(def ^:private minimal-circle-attrs
{:type :circle
:name "Ellipse"
:fills [{:fill-color default-color
:fill-opacity 1}]
:strokes []})
{:type :image
:rx 0
:ry 0
:fills []
:strokes []}
(def ^:private minimal-group-attrs
{:type :group
:name "Group"
:shapes []})
{:type :circle
:name "Ellipse"
:fills [{:fill-color default-color
:fill-opacity 1}]
:strokes []}
(def ^:private minimal-bool-attrs
{:type :bool
:name "Bool"
:shapes []})
{:type :path
:name "Path"
:fills []
:strokes [{:stroke-style :solid
:stroke-alignment :center
:stroke-width 2
:stroke-color clr/black
:stroke-opacity 1}]}
(def ^:private minimal-text-attrs
{:type :text
:name "Text"})
{:type :frame
:name "Board"
:fills [{:fill-color clr/white
:fill-opacity 1}]
:strokes []
:rx 0
:ry 0}
(def ^:private minimal-path-attrs
{:type :path
:name "Path"
:fills []
:strokes [{:stroke-style :solid
:stroke-alignment :center
:stroke-width 2
:stroke-color clr/black
:stroke-opacity 1}]})
{:type :text
:name "Text"
:content nil}
(def ^:private minimal-svg-raw-attrs
{:type :svg-raw
:fills []
:strokes []})
{:type :svg-raw}])
(def ^:private minimal-multiple-attrs
{:type :multiple})
(def empty-selrect
{:x 0 :y 0
:x1 0 :y1 0
:x2 0.01 :y2 0.01
:width 0.01 :height 0.01})
(defn make-minimal-shape
(defn- get-minimal-shape
[type]
(let [type (cond (= type :curve) :path
:else type)
shape (d/seek #(= type (:type %)) minimal-shapes)]
(when-not shape
(ex/raise :type :assertion
:code :shape-type-not-implemented
:context {:type type}))
(case type
:rect minimal-rect-attrs
:image minimal-image-attrs
:circle minimal-circle-attrs
:path minimal-path-attrs
:frame minimal-frame-attrs
:bool minimal-bool-attrs
:group minimal-group-attrs
:text minimal-text-attrs
:svg-raw minimal-svg-raw-attrs
;; NOTE: used for create ephimeral shapes for multiple selection
:multiple minimal-multiple-attrs))
(defn- make-minimal-shape
[type]
(let [type (if (= type :curve) :path type)
attrs (get-minimal-shape type)]
(cond-> attrs
(not= :path type)
(-> (assoc :x 0)
(assoc :y 0)
(assoc :width 0.01)
(assoc :height 0.01))
(cond-> shape
:always
(assoc :id (uuid/next))
(assoc :id (uuid/next)
:frame-id uuid/zero
:parent-id uuid/zero
:rotation 0)
(not= :path (:type shape))
(assoc :x 0
:y 0
:width 0.01
:height 0.01
:selrect {:x 0
:y 0
:x1 0
:y1 0
:x2 0.01
:y2 0.01
:width 0.01
:height 0.01}))))
:always
(map->Shape))))
(defn make-minimal-group
[frame-id rect group-name]
{:id (uuid/next)
:type :group
:name group-name
:shapes []
:frame-id frame-id
:x (:x rect)
:y (:y rect)
:width (:width rect)
:height (:height rect)})
(defn setup-rect-selrect
(defn setup-rect
"Initializes the selrect and points for a shape."
[shape]
(let [selrect (gsh/rect->selrect shape)
points (gsh/rect->points shape)
points (cond-> points
(:transform shape)
(gsh/transform-points (gsh/center-points points) (:transform shape)))]
[{:keys [selrect points] :as shape}]
(let [selrect (or selrect (gsh/shape->rect shape))
points (or points (grc/rect->points selrect))]
(-> shape
(assoc :selrect selrect
:points points))))
(assoc :selrect selrect)
(assoc :points points))))
(defn- setup-rect
"A specialized function for setup rect-like shapes."
[shape {:keys [x y width height]}]
(-> shape
(assoc :x x :y y :width width :height height)
(setup-rect-selrect)))
(defn setup-path
[{:keys [content selrect points] :as shape}]
(let [selrect (or selrect
(gsh/content->selrect content)
(grc/make-rect))
points (or points (grc/rect->points selrect))]
(-> shape
(assoc :selrect selrect)
(assoc :points points))))
(defn- setup-image
[shape props]
(let [metadata (or (:metadata shape) (:metadata props))]
(-> (setup-rect shape props)
(assoc
:metadata metadata
:proportion (/ (:width metadata)
(:height metadata))
:proportion-lock true))))
[{:keys [metadata] :as shape}]
(-> shape
(assoc :proportion (/ (:width metadata)
(:height metadata)))
(assoc :proportion-lock true)))
(defn setup-shape
"A function that initializes the geometric data of
the shape. The props must have :x :y :width :height."
([props]
(setup-shape {:type :rect} props))
[{:keys [type] :as props}]
(let [shape (make-minimal-shape type)
shape (merge shape (d/without-nils props))
shape (case (:type shape)
:path (setup-path shape)
:image (-> shape setup-rect setup-image)
(setup-rect shape))]
(-> shape
(cond-> (nil? (:transform shape))
(assoc :transform (gmt/matrix)))
(cond-> (nil? (:transform-inverse shape))
(assoc :transform-inverse (gmt/matrix)))
(gpr/setup-proportions))))
([shape props]
(case (:type shape)
:image (setup-image shape props)
(setup-rect shape props))))
;; --- SHAPE SERIALIZATION
(defn make-shape
"Make a non group shape, ready to use."
[type geom-props attrs]
(-> (if-not (= type :group)
(make-minimal-shape type)
(make-minimal-group uuid/zero geom-props (:name attrs)))
(setup-shape geom-props)
(merge attrs)))
(t/add-handlers!
{:id "shape"
:class Shape
:wfn #(into {} %)
:rfn map->Shape})
#?(:clj
(fres/add-handlers!
{:name "penpot/shape"
:class Shape
:wfn fres/write-map-like
:rfn (comp map->Shape fres/read-map-like)}))

133
common/src/app/common/pages/common.cljc → common/src/app/common/types/shape/attrs.cljc
View File

@ -4,111 +4,11 @@
;;
;; Copyright (c) KALEIDOS INC
(ns app.common.pages.common
(ns app.common.types.shape.attrs
(:require
[app.common.colors :as clr]
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.schema :as sm]
[app.common.uuid :as uuid]))
[app.common.colors :as clr]))
(def file-version 20)
(def default-color clr/gray-20)
(def root uuid/zero)
;; Attributes that may be synced in components, and the group they belong to.
;; When one attribute is modified in a shape inside a component, the corresponding
;; group is marked as :touched. Then, if the shape is synced with the remote shape
;; in the main component, none of the attributes of the same group is changed.
(def component-sync-attrs
{:name :name-group
:fills :fill-group
:fill-color :fill-group
:fill-opacity :fill-group
:fill-color-gradient :fill-group
:fill-color-ref-file :fill-group
:fill-color-ref-id :fill-group
:hide-fill-on-export :fill-group
:content :content-group
:position-data :content-group
:hidden :visibility-group
:blocked :modifiable-group
:grow-type :text-font-group
:font-family :text-font-group
:font-size :text-font-group
:font-style :text-font-group
:font-weight :text-font-group
:letter-spacing :text-display-group
:line-height :text-display-group
:text-align :text-display-group
:strokes :stroke-group
:stroke-color :stroke-group
:stroke-color-gradient :stroke-group
:stroke-color-ref-file :stroke-group
:stroke-color-ref-id :stroke-group
:stroke-opacity :stroke-group
:stroke-style :stroke-group
:stroke-width :stroke-group
:stroke-alignment :stroke-group
:stroke-cap-start :stroke-group
:stroke-cap-end :stroke-group
:rx :radius-group
:ry :radius-group
:r1 :radius-group
:r2 :radius-group
:r3 :radius-group
:r4 :radius-group
:type :geometry-group
:selrect :geometry-group
:points :geometry-group
:locked :geometry-group
:proportion :geometry-group
:proportion-lock :geometry-group
:x :geometry-group
:y :geometry-group
:width :geometry-group
:height :geometry-group
:rotation :geometry-group
:transform :geometry-group
:transform-inverse :geometry-group
:opacity :layer-effects-group
:blend-mode :layer-effects-group
:shadow :shadow-group
:blur :blur-group
:masked-group? :mask-group
:constraints-h :constraints-group
:constraints-v :constraints-group
:fixed-scroll :constraints-group
:exports :exports-group
:layout :layout-container
:layout-align-content :layout-container
:layout-align-items :layout-container
:layout-flex-dir :layout-container
:layout-gap :layout-container
:layout-gap-type :layout-container
:layout-justify-content :layout-container
:layout-justify-items :layout-container
:layout-wrap-type :layout-container
:layout-padding-type :layout-container
:layout-padding :layout-container
:layout-h-orientation :layout-container
:layout-v-orientation :layout-container
:layout-grid-dir :layout-container
:layout-grid-rows :layout-container
:layout-grid-columns :layout-container
:layout-grid-cells :layout-container
:layout-item-margin :layout-item
:layout-item-margin-type :layout-item
:layout-item-h-sizing :layout-item
:layout-item-v-sizing :layout-item
:layout-item-max-h :layout-item
:layout-item-min-h :layout-item
:layout-item-max-w :layout-item
:layout-item-min-w :layout-item
:layout-item-align-self :layout-item})
;; Attributes that may directly be edited by the user with forms
(def editable-attrs
@ -594,33 +494,4 @@
:layout-item-min-w
:layout-item-align-self}})
(defn retrieve-used-names
"Return a set with the all unique names used in the
elements (any entity thas has a :name)"
[elements]
(into #{} (comp (map :name) (remove nil?)) (vals elements)))
(defn- extract-numeric-suffix
[basename]
(if-let [[_ p1 p2] (re-find #"(.*) ([0-9]+)$" basename)]
[p1 (+ 1 (d/parse-integer p2))]
[basename 1]))
(defn generate-unique-name
"A unique name generator"
[used basename]
(dm/assert!
"expected a set of strings"
(sm/set-of-strings? used))
(dm/assert!
"expected a string for `basename`."
(string? basename))
(if-not (contains? used basename)
basename
(let [[prefix initial] (extract-numeric-suffix basename)]
(loop [counter initial]
(let [candidate (str prefix " " counter)]
(if (contains? used candidate)
(recur (inc counter))
candidate))))))

2
common/src/app/common/types/shape/interactions.cljc
View File

@ -182,7 +182,7 @@
(dm/assert!
"The `:after-delay` event type incompatible with frame shapes"
(or (not= event-type :after-delay)
(= (:type shape) :frame)))
(cph/frame-shape? shape)))
(if (= (:event-type interaction) event-type)
interaction

2
common/src/app/common/types/shape/radius.cljc
View File

@ -6,7 +6,7 @@
(ns app.common.types.shape.radius
(:require
[app.common.pages.common :refer [editable-attrs]]))
[app.common.types.shape.attrs :refer [editable-attrs]]))
;; There are some shapes that admit border radius, as rectangles
;; frames and images. Those shapes may define the radius of the corners in two modes:

13
common/src/app/common/types/shape_tree.cljc
View File

@ -41,7 +41,7 @@
(update :shapes d/vec-without-nils)
(cond-> (and (ctk/in-component-copy? parent) (not ignore-touched))
(-> (update :touched cph/set-touched-group :shapes-group)
(dissoc :remote-synced?)))))
(dissoc :remote-synced)))))
update-objects
(fn [objects parent-id]
@ -86,7 +86,7 @@
(cond-> parent
(and (:shape-ref parent) (not ignore-touched))
(-> (update :touched cph/set-touched-group :shapes-group)
(dissoc :remote-synced?)))))
(dissoc :remote-synced)))))
(delete-from-objects [objects]
(if-let [target (get objects shape-id)]
@ -322,10 +322,9 @@
(not (mth/almost-zero? (:rotation frame 0))))
(defn clone-object
"Gets a copy of the object and all its children, with new ids
and with the parent-children links correctly set. Admits functions
to make more transformations to the cloned objects and the
original ones.
"Gets a copy of the object and all its children, with new ids and with
the parent-children links correctly set. Admits functions to make
more transformations to the cloned objects and the original ones.
Returns the cloned object, the list of all new objects (including
the cloned one), and possibly a list of original objects modified.
@ -357,7 +356,7 @@
(if (empty? child-ids)
(let [new-object (cond-> object
true
:always
(assoc :id new-id
:parent-id parent-id)

10
common/test/common_tests/pages_migrations_test.cljc → common/test/common_tests/files_migrations_test.cljc
View File

@ -4,14 +4,14 @@
;;
;; Copyright (c) KALEIDOS INC
(ns common-tests.pages-migrations-test
(ns common-tests.files-migrations-test
(:require
[clojure.test :as t]
[clojure.pprint :refer [pprint]]
[app.common.data :as d]
[app.common.files.migrations :as cpm]
[app.common.pages :as cp]
[app.common.pages.migrations :as cpm]
[app.common.uuid :as uuid]))
[app.common.uuid :as uuid]
[clojure.pprint :refer [pprint]]
[clojure.test :as t]))
(t/deftest test-migration-8-1
(let [page-id (uuid/custom 0 0)

144
common/test/common_tests/geom_shapes_test.cljc
View File

@ -8,6 +8,7 @@
(:require
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.geom.shapes.transforms :as gsht]
[app.common.math :as mth :refer [close?]]
@ -22,35 +23,19 @@
{:command :curve-to :params {:x 40 :y 40 :c1x 35 :c1y 35 :c2x 45 :c2y 45}}
{:command :close-path}])
(defn add-path-data
[shape]
(let [content (:content shape default-path)
selrect (gsh/content->selrect content)
points (gsh/rect->points selrect)]
(assoc shape
:content content
:selrect selrect
:points points)))
(defn add-rect-data
[shape]
(let [shape (-> shape
(assoc :width 20 :height 20))
selrect (gsh/rect->selrect shape)
points (gsh/rect->points selrect)]
(assoc shape
:selrect selrect
:points points)))
(defn create-test-shape
([type] (create-test-shape type {}))
([type params]
(-> (cts/make-minimal-shape type)
(merge params)
(cond->
(= type :path) (add-path-data)
(not= type :path) (add-rect-data)))))
(if (= type :path)
(cts/setup-shape
(into {:type :path
:content (:content params default-path)}
params))
(cts/setup-shape
(into {:type type
:width 20
:height 20}
params)))))
(t/deftest transform-shapes
(t/testing "Shape without modifiers should stay the same"
@ -62,25 +47,25 @@
:rect :path))
(t/testing "Transform shape with translation modifiers"
(t/are [type]
(let [modifiers (ctm/move-modifiers (gpt/point 10 -10))]
(let [shape-before (create-test-shape type {:modifiers modifiers})
shape-after (gsh/transform-shape shape-before)]
(t/is (not= shape-before shape-after))
(doseq [type [:rect :path]]
(let [modifiers (ctm/move-modifiers (gpt/point 10 -10))
shape-before (create-test-shape type {:modifiers modifiers})
shape-after (gsh/transform-shape shape-before)]
(t/is (close? (get-in shape-before [:selrect :x])
(- 10 (get-in shape-after [:selrect :x]))))
(t/is (not= shape-before shape-after))
(t/is (close? (get-in shape-before [:selrect :y])
(+ 10 (get-in shape-after [:selrect :y]))))
(t/is (close? (get-in shape-before [:selrect :x])
(- 10 (get-in shape-after [:selrect :x]))))
(t/is (close? (get-in shape-before [:selrect :width])
(get-in shape-after [:selrect :width])))
(t/is (close? (get-in shape-before [:selrect :y])
(+ 10 (get-in shape-after [:selrect :y]))))
(t/is (close? (get-in shape-before [:selrect :height])
(get-in shape-after [:selrect :height])))))
(t/is (close? (get-in shape-before [:selrect :width])
(get-in shape-after [:selrect :width])))
:rect :path))
(t/is (close? (get-in shape-before [:selrect :height])
(get-in shape-after [:selrect :height])))
)))
(t/testing "Transform with empty translation"
(t/are [type]
@ -125,20 +110,19 @@
:rect :path))
(t/testing "Transform with resize=0"
(t/are [type]
(let [modifiers (ctm/resize-modifiers (gpt/point 0 0) (gpt/point 0 0))
shape-before (create-test-shape type {:modifiers modifiers})
shape-after (gsh/transform-shape shape-before)]
(t/is (close? (get-in shape-before [:selrect :width])
(get-in shape-after [:selrect :width])))
(t/is (close? (get-in shape-before [:selrect :height])
(get-in shape-after [:selrect :height]))))
:rect :path))
(let [modifiers (ctm/resize-modifiers (gpt/point 0 0) (gpt/point 0 0))
shape-before (create-test-shape :rect {:modifiers modifiers})
shape-after (gsh/transform-shape shape-before)]
(t/is (close? (get-in shape-before [:selrect :width])
(get-in shape-after [:selrect :width])))
(t/is (close? (get-in shape-before [:selrect :height])
(get-in shape-after [:selrect :height])))))
(t/testing "Transform shape with rotation modifiers"
(t/are [type]
(let [shape-before (create-test-shape type)
modifiers (ctm/rotation-modifiers shape-before (gsh/center-shape shape-before) 30)
modifiers (ctm/rotation-modifiers shape-before (gsh/shape->center shape-before) 30)
shape-before (assoc shape-before :modifiers modifiers)
shape-after (gsh/transform-shape shape-before)]
@ -160,7 +144,7 @@
(t/testing "Transform shape with rotation = 0 should leave equal selrect"
(t/are [type]
(let [shape-before (create-test-shape type)
modifiers (ctm/rotation-modifiers shape-before (gsh/center-shape shape-before) 0)
modifiers (ctm/rotation-modifiers shape-before (gsh/shape->center shape-before) 0)
shape-after (gsh/transform-shape (assoc shape-before :modifiers modifiers))]
(t/are [prop]
(t/is (close? (get-in shape-before [:selrect prop])
@ -170,24 +154,24 @@
(t/testing "Transform shape with invalid selrect fails gracefully"
(t/are [type selrect]
(let [modifiers (ctm/move-modifiers 0 0)
shape-before (-> (create-test-shape type) (assoc :selrect selrect))
(let [modifiers (ctm/move-modifiers 0 0)
shape-before (create-test-shape type {:selrect selrect})
shape-after (gsh/transform-shape shape-before modifiers)]
(t/is (= (:selrect shape-before)
(:selrect shape-after))))
:rect {:x 0.0 :y 0.0 :x1 0.0 :y1 0.0 :x2 ##Inf :y2 ##Inf :width ##Inf :height ##Inf}
:path {:x 0.0 :y 0.0 :x1 0.0 :y1 0.0 :x2 ##Inf :y2 ##Inf :width ##Inf :height ##Inf}
:rect nil
:path nil)))
(t/is (grc/close-rect? (:selrect shape-before)
(:selrect shape-after))))
:rect (grc/make-rect 0 0 ##Inf ##Inf)
:path (grc/make-rect 0 0 ##Inf ##Inf)
))
)
(t/deftest points-to-selrect
(let [points [(gpt/point 0.5 0.5)
(gpt/point -1 -2)
(gpt/point 20 65.2)
(gpt/point 12 -10)]
result (gsh/points->rect points)
result (grc/points->rect points)
expect {:x -1, :y -10, :width 21, :height 75.2}]
(t/is (= (:x expect) (:x result)))
@ -204,39 +188,39 @@
(t/is (gmt/close? expected result)))
;; No transformation
(gsh/make-selrect 0 0 10 10)
(-> (gsh/make-selrect 0 0 10 10)
(gsh/rect->points))
(grc/make-rect 0 0 10 10)
(-> (grc/make-rect 0 0 10 10)
(grc/rect->points))
(gmt/matrix)
;; Displacement
(gsh/make-selrect 0 0 10 10)
(-> (gsh/make-selrect 20 20 10 10)
(gsh/rect->points ))
(grc/make-rect 0 0 10 10)
(-> (grc/make-rect 20 20 10 10)
(grc/rect->points ))
(gmt/matrix 1 0 0 1 20 20)
;; Resize
(gsh/make-selrect 0 0 10 10)
(-> (gsh/make-selrect 0 0 20 40)
(gsh/rect->points))
(grc/make-rect 0 0 10 10)
(-> (grc/make-rect 0 0 20 40)
(grc/rect->points))
(gmt/matrix 2 0 0 4 0 0)
;; Displacement+Resize
(gsh/make-selrect 0 0 10 10)
(-> (gsh/make-selrect 10 10 20 40)
(gsh/rect->points))
(grc/make-rect 0 0 10 10)
(-> (grc/make-rect 10 10 20 40)
(grc/rect->points))
(gmt/matrix 2 0 0 4 10 10)
;; Rotation
(gsh/make-selrect 0 0 10 10)
(-> (gsh/make-selrect 0 0 10 10)
(gsh/rect->points)
(grc/make-rect 0 0 10 10)
(-> (grc/make-rect 0 0 10 10)
(grc/rect->points)
(gsh/transform-points (gmt/rotate-matrix 45)))
(gmt/matrix (mth/cos g45) (mth/sin g45) (- (mth/sin g45)) (mth/cos g45) 0 0)
;; Rotation + Resize
(gsh/make-selrect 0 0 10 10)
(-> (gsh/make-selrect 0 0 20 40)
(gsh/rect->points)
(grc/make-rect 0 0 10 10)
(-> (grc/make-rect 0 0 20 40)
(grc/rect->points)
(gsh/transform-points (gmt/rotate-matrix 45)))
(gmt/matrix (* (mth/cos g45) 2) (* (mth/sin g45) 2) (* (- (mth/sin g45)) 4) (* (mth/cos g45) 4) 0 0))))

12
common/test/common_tests/helpers/files.cljc
View File

@ -49,13 +49,11 @@
(fn [file-data]
(let [frame-id (get props :frame-id uuid/zero)
parent-id (get props :parent-id uuid/zero)
shape (if (= type :group)
(cts/make-minimal-group frame-id
{:x 0 :y 0 :width 1 :height 1}
(get props :name "Group1"))
(cts/make-shape type
{:x 0 :y 0 :width 1 :height 1}
props))]
shape (cts/setup-shape
(-> {:type type
:width 1
:height 1}
(merge props)))]
(swap! idmap assoc label (:id shape))
(ctpl/update-page file-data

1065
common/test/common_tests/pages_test.cljc
View File

File diff suppressed because it is too large Load Diff

55
common/test/common_tests/record_test.cljc Normal file
View File

@ -0,0 +1,55 @@
;; 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) KALEIDOS INC
(ns common-tests.record-test
(:require
[app.common.data.macros :as dm]
[app.common.record :as cr]
[clojure.test :as t]))
(cr/defrecord Sample [a b])
(t/deftest operations
(let [o (pos->Sample 1 2)]
(t/testing "get"
(t/is (= 1 (:a o)))
(t/is (= 1 (get o :a)))
(t/is (= nil (get o :c)))
(t/is (= :foo (get o :c :foo))))
(t/testing "known assoc"
(let [o (assoc o :a 100)]
(t/is (= 100 (:a o)))))
(t/testing "unknown assoc"
(let [o (assoc o :c 176)]
(prn o)
(t/is (= 1 (:a o)))
(t/is (= 2 (:b o)))
(t/is (= 176 (:c o)))))
(t/testing "contains"
(let [o (assoc o :c 176)]
(t/is (contains? o :a))
(t/is (contains? o :b))
(t/is (contains? o :c))
(t/is (not (contains? o :d)))))
#?(:cljs
(t/testing "transients"
(let [o (assoc o :c 123)
u (cr/clone o)]
(cr/assoc! u :a 10)
(cr/assoc! u :b 20)
(cr/assoc! u :c 124)
(t/is (= 10 (dm/get-prop u :a)))
(t/is (= 20 (dm/get-prop u :b)))
(t/is (= 124 (:c u)))
(t/is (not= u o)))))
))

79
common/test/common_tests/types_shape_interactions_test.cljc
View File

@ -6,9 +6,10 @@
(ns common-tests.types-shape-interactions-test
(:require
[app.common.geom.shapes :as gsh]
[app.common.exceptions :as ex]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.types.shape :as cts]
[app.common.types.shape.interactions :as ctsi]
[app.common.uuid :as uuid]
@ -17,8 +18,8 @@
(t/deftest set-event-type
(let [interaction ctsi/default-interaction
shape (cts/make-minimal-shape :rect)
frame (cts/make-minimal-shape :frame)]
shape (cts/setup-shape {:type :rect})
frame (cts/setup-shape {:type :frame})]
(t/testing "Set event type unchanged"
(let [new-interaction
@ -46,7 +47,8 @@
new-interaction
(ctsi/set-event-type interaction :after-delay frame)]
(t/is (= :after-delay (:event-type new-interaction)))
(t/is (= 300 (:delay new-interaction)))))))
(t/is (= 300 (:delay new-interaction)))))
))
(t/deftest set-action-type
@ -148,7 +150,7 @@
(t/is (= "https://example.com" (:url new-interaction)))))))
(t/deftest option-delay
(let [frame (cts/make-minimal-shape :frame)
(let [frame (cts/setup-shape {:type :frame})
i1 ctsi/default-interaction
i2 (ctsi/set-event-type i1 :after-delay frame)]
@ -160,7 +162,6 @@
(let [new-interaction (ctsi/set-delay i2 1000)]
(t/is (= 1000 (:delay new-interaction)))))))
(t/deftest option-destination
(let [destination (uuid/next)
i1 ctsi/default-interaction
@ -211,10 +212,10 @@
(t/deftest option-overlay-opts
(let [base-frame (-> (cts/make-minimal-shape :frame)
(let [base-frame (-> (cts/setup-shape {:type :frame})
(assoc-in [:selrect :width] 100)
(assoc-in [:selrect :height] 100))
overlay-frame (-> (cts/make-minimal-shape :frame)
overlay-frame (-> (cts/setup-shape {:type :frame})
(assoc-in [:selrect :width] 30)
(assoc-in [:selrect :height] 20))
objects {(:id base-frame) base-frame
@ -277,37 +278,35 @@
(t/is (= relative-to-id (:position-relative-to new-interaction)))))))
(defn setup-selrect [{:keys [x y width height] :as obj}]
(let [rect (gsh/make-rect x y width height)
center (gsh/center-rect rect)
selrect (gsh/rect->selrect rect)
points (gsh/rect->points rect)]
(let [rect (grc/make-rect x y width height)
center (grc/rect->center rect)
points (grc/rect->points rect)]
(-> obj
(assoc :selrect selrect)
(assoc :selrect rect)
(assoc :points points))))
(t/deftest calc-overlay-position
(let [base-frame (-> (cts/make-minimal-shape :frame)
(assoc :width 100)
(assoc :height 100)
(setup-selrect))
popup (-> (cts/make-minimal-shape :frame)
(assoc :width 50)
(assoc :height 50)
(assoc :x 10)
(assoc :y 10)
(setup-selrect))
(let [base-frame (cts/setup-shape
{:type :frame
:width 100
:height 100})
popup (cts/setup-shape
{:type :frame
:width 50
:height 50
:x 10
:y 10})
rect (cts/setup-shape
{:type :rect
:width 50
:height 50
:x 10
:y 10})
rect (-> (cts/make-minimal-shape :rect)
(assoc :width 50)
(assoc :height 50)
(assoc :x 10)
(assoc :y 10)
(setup-selrect))
overlay-frame (-> (cts/make-minimal-shape :frame)
(assoc :width 30)
(assoc :height 20)
(setup-selrect))
overlay-frame (cts/setup-shape
{:type :frame
:width 30
:height 20})
objects {(:id base-frame) base-frame
(:id popup) popup
@ -798,12 +797,12 @@
(t/deftest remap-interactions
(let [frame1 (cts/make-minimal-shape :frame)
frame2 (cts/make-minimal-shape :frame)
frame3 (cts/make-minimal-shape :frame)
frame4 (cts/make-minimal-shape :frame)
frame5 (cts/make-minimal-shape :frame)
frame6 (cts/make-minimal-shape :frame)
(let [frame1 (cts/setup-shape {:type :frame})
frame2 (cts/setup-shape {:type :frame})
frame3 (cts/setup-shape {:type :frame})
frame4 (cts/setup-shape {:type :frame})
frame5 (cts/setup-shape {:type :frame})
frame6 (cts/setup-shape {:type :frame})
objects {(:id frame3) frame3
(:id frame4) frame4

3
common/test/common_tests/types_test.cljc
View File

@ -24,7 +24,8 @@
(t/deftest types-shape-spec
(sg/check!
(sg/for [fdata (sg/generator ::cts/shape)]
(t/is (sm/validate ::cts/shape fdata)))))
(binding [app.common.data.macros/*assert-context* true]
(t/is (sm/valid? ::cts/shape fdata))))))
(t/deftest types-page-spec
(-> (sg/for [fdata (sg/generator ::ctp/page)]

4
frontend/deps.edn
View File

@ -13,8 +13,8 @@
funcool/tubax {:mvn/version "2021.05.20-0"}
funcool/rumext
{:git/tag "v2.3"
:git/sha "09942e7"
{:git/tag "v2.6"
:git/sha "97203a5"
:git/url "https://github.com/funcool/rumext.git"
}

128
frontend/dev/bench.cljs
View File

@ -3,63 +3,95 @@
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.rect :as gsr]
[app.common.perf :as perf]
[app.common.geom.matrix :as gmt]
[app.common.geom.shapes.transforms :as gst]
[app.common.record :as cr]
[app.common.geom.rect :as grc]
[app.common.geom.rect_impl :as grci]
[app.common.types.modifiers :as ctm]
[clojure.spec.alpha :as s]
[clojure.test.check.generators :as gen]))
[app.common.types.shape :as cts]
[app.util.perf :as perf]))
(def points
(gen/sample (s/gen ::gpt/point) 20))
(defn bench-points
(defn random
[]
#_(perf/benchmark
:f #(gpt/center-points-old points)
:samples 20
:max-iterations 500000
:name "base")
(perf/benchmark
:f #(gpt/center-points points)
:max-iterations 500000
:samples 20
:name "optimized"))
(js/Math.random))
(def modifiers
(-> (ctm/empty)
(ctm/move (gpt/point 100 200))
(ctm/resize (gpt/point 100 200) (gpt/point 2.0 0.5))
(ctm/move (gpt/point -100 -200))
(ctm/resize (gpt/point 100 200) (gpt/point 2.0 0.5))
(ctm/rotation (gpt/point 0 0) -100)
(ctm/resize (gpt/point 100 200) (gpt/point 2.0 0.5))))
(defn bench-modifiers
(defn force-gc
[]
(perf/benchmark
:f #(ctm/modifiers->transform modifiers)
:max-iterations 50000
:samples 20
:name "current")
(js/gc))
#_(perf/benchmark
:f #(ctm/modifiers->transform-2 modifiers)
:max-iterations 50000
:samples 20
:name "optimized"))
;; (defn bench-modifiers
;; []
;; (println "")
;; (println "===> BENCH MODIFIERS <===")
;; (let [modifiers (-> (ctm/empty)
;; (ctm/move (gpt/point 100 200))
;; (ctm/resize (gpt/point 100 200) (gpt/point 2.0 0.5))
;; (ctm/move (gpt/point -100 -200))
;; (ctm/resize (gpt/point 100 200) (gpt/point 2.0 0.5))
;; (ctm/rotation (gpt/point 0 0) -100)
;; (ctm/resize (gpt/point 100 200) (gpt/point 2.0 0.5)))]
;; (perf/benchmark
;; :gc force-gc
;; :iterations 50000
;; :name "modifiers->transform:old"
;; :run-fn #(ctm/modifiers->transform-old modifiers))
;; (perf/benchmark
;; :gc force-gc
;; :iterations 50000
;; :name "modifiers->transform:new"
;; :run-fn #(ctm/modifiers->transform modifiers))))
;; (defn bench-apply-transform
;; []
;; (println "")
;; (println "===> BENCH APPLY TRANFORM <===")
;; (let [modifiers (-> (ctm/empty)
;; (ctm/move (gpt/point 100 200))
;; (ctm/resize (gpt/point 100 200) (gpt/point 2.0 0.5))
;; (ctm/move (gpt/point -100 -200))
;; (ctm/resize (gpt/point 100 200) (gpt/point 2.0 0.5))
;; (ctm/rotation (gpt/point 0 0) -100)
;; (ctm/resize (gpt/point 100 200) (gpt/point 2.0 0.5)))
;; transform (ctm/modifiers->transform modifiers)
;; shape (cts/setup-shape {:type :rect
;; :x 0
;; :y 0
;; :width 10
;; :height 10})]
;; ;; (app.common.pprint/pprint shape)
;; (perf/benchmark
;; :gc force-gc
;; :iterations 400
;; :name "apply-transform:old"
;; :run-fn #(gst/apply-transform shape modifiers))
;; (perf/benchmark
;; :gc force-gc
;; :iterations 400
;; :name "apply-transform:new"
;; :run-fn #(gst/apply-transform' shape modifiers))
;; ))
;; (ctm/modifiers->transform-2 modifiers)
(defn ^:dev/after-load after-load
[]
#_(bench-modifiers))
;; (bench-apply-transform)
;; (let [o (grc/make-rect 1 1 10 10)]
;; (prn o)
;; (prn (-> o
;; (cr/assoc! :x 40)
;; (grc/update-rect! :size)))
;; )
)
(defn main
[& [name]]
(case name
"points" (bench-points)
"modifiers" (bench-modifiers)
(println "available: points"))
#_(.exit js/process 0))
[& params]
;; (bench-apply-transform)
;; (bench-apply-transform)
nil)

20
frontend/package.json
View File

@ -12,18 +12,18 @@
"defaults"
],
"scripts": {
"compile-test": "clojure -M:dev:shadow-cljs compile test --config-merge '{:autorun false}'",
"lint": "clj-kondo --parallel --lint src/",
"lint-scss": "yarn run prettier -c resources/styles -c src/**/*.scss",
"run-test": "node target/tests.js",
"test": "yarn run compile-test && yarn run run-test",
"watch-gulp": "gulp watch",
"watch-main": "shadow-cljs watch main",
"watch-test": "clojure -M:dev:shadow-cljs watch test",
"test:compile": "clojure -M:dev:shadow-cljs compile test --config-merge '{:autorun false}'",
"lint:clj": "clj-kondo --parallel --lint src/",
"lint:scss": "yarn run prettier -c resources/styles -c src/**/*.scss",
"test:run": "node target/tests.js",
"test:watch": "clojure -M:dev:shadow-cljs watch test",
"test": "yarn run test:compile && yarn run test:run",
"gulp:watch": "gulp watch",
"watch": "shadow-cljs watch main",
"validate-translations": "node ./scripts/validate-translations.js",
"find-unused-translations": "node ./scripts/find-unused-translations.js",
"test-e2e": "cypress run",
"test-e2e-gui": "cypress open"
"test:e2e": "cypress run",
"test:e2e-gui": "cypress open"
},
"devDependencies": {
"autoprefixer": "^10.4.13",

2
frontend/src/app/libs/file_builder.cljs
View File

@ -7,7 +7,7 @@
(ns app.libs.file-builder
(:require
[app.common.data :as d]
[app.common.file-builder :as fb]
[app.common.files.builder :as fb]
[app.common.media :as cm]
[app.common.types.components-list :as ctkl]
[app.common.uuid :as uuid]

18
frontend/src/app/main/data/dashboard.cljs
View File

@ -8,7 +8,7 @@
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.pages :as cp]
[app.common.files.helpers :as cfh]
[app.common.schema :as sm]
[app.common.time :as dt]
[app.common.uri :as u]
@ -607,8 +607,8 @@
ptk/WatchEvent
(watch [_ state _]
(let [projects (get state :dashboard-projects)
unames (cp/retrieve-used-names projects)
name (cp/generate-unique-name unames (str (tr "dashboard.new-project-prefix") " 1"))
unames (cfh/get-used-names projects)
name (cfh/generate-unique-name unames (str (tr "dashboard.new-project-prefix") " 1"))
team-id (:current-team-id state)
params {:name name
:team-id team-id}
@ -823,8 +823,8 @@
on-error rx/throw}} (meta params)
files (get state :dashboard-files)
unames (cp/retrieve-used-names files)
name (cp/generate-unique-name unames (str (tr "dashboard.new-file-prefix") " 1"))
unames (cfh/get-used-names files)
name (cfh/generate-unique-name unames (str (tr "dashboard.new-file-prefix") " 1"))
features (cond-> #{}
(features/active-feature? state :components-v2)
(conj "components/v2"))
@ -1033,11 +1033,11 @@
in-project? (contains? pparams :project-id)
name (if in-project?
(let [files (get state :dashboard-files)
unames (cp/retrieve-used-names files)]
(cp/generate-unique-name unames (str (tr "dashboard.new-file-prefix") " 1")))
unames (cfh/get-used-names files)]
(cfh/generate-unique-name unames (str (tr "dashboard.new-file-prefix") " 1")))
(let [projects (get state :dashboard-projects)
unames (cp/retrieve-used-names projects)]
(cp/generate-unique-name unames (str (tr "dashboard.new-project-prefix") " 1"))))
unames (cfh/get-used-names projects)]
(cfh/generate-unique-name unames (str (tr "dashboard.new-project-prefix") " 1"))))
params (if in-project?
{:project-id (:project-id pparams)
:name name}

76
frontend/src/app/main/data/workspace.cljs
View File

@ -10,13 +10,14 @@
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.files.features :as ffeat]
[app.common.files.helpers :as cfh]
[app.common.geom.align :as gal]
[app.common.geom.point :as gpt]
[app.common.geom.proportions :as gpp]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.geom.shapes.grid-layout :as gslg]
[app.common.logging :as log]
[app.common.pages :as cp]
[app.common.pages.changes-builder :as pcb]
[app.common.pages.helpers :as cph]
[app.common.text :as txt]
@ -436,8 +437,8 @@
ptk/WatchEvent
(watch [it state _]
(let [pages (get-in state [:workspace-data :pages-index])
unames (cp/retrieve-used-names pages)
name (cp/generate-unique-name unames "Page 1")
unames (cfh/get-used-names pages)
name (cfh/generate-unique-name unames "Page 1")
changes (-> (pcb/empty-changes it)
(pcb/add-empty-page id name))]
@ -451,9 +452,9 @@
(watch [it state _]
(let [id (uuid/next)
pages (get-in state [:workspace-data :pages-index])
unames (cp/retrieve-used-names pages)
unames (cfh/get-used-names pages)
page (get-in state [:workspace-data :pages-index page-id])
name (cp/generate-unique-name unames (:name page))
name (cfh/generate-unique-name unames (:name page))
page (-> page
(assoc :name name)
@ -491,7 +492,7 @@
(let [components-to-delete (->> page
:objects
vals
(filter #(true? (:main-instance? %)))
(filter #(true? (:main-instance %)))
(map :component-id))
changes (reduce (fn [changes component-id]
@ -597,7 +598,7 @@
(defn update-shape
[id attrs]
(dm/assert! (uuid? id))
(dm/assert! (cts/shape-attrs? attrs))
(dm/assert! (cts/valid-shape-attrs? attrs))
(ptk/reify ::update-shape
ptk/WatchEvent
(watch [_ _ _]
@ -631,7 +632,7 @@
(rx/of (update-shape shape-id {:name name})))
;; Update the component in case if shape is a main instance
(when (:main-instance? shape)
(when (:main-instance shape)
(when-let [component-id (:component-id shape)]
(rx/of (dwl/rename-component component-id name)))))))))))
@ -641,7 +642,7 @@
(defn update-selected-shapes
[attrs]
(dm/assert! (cts/shape-attrs? attrs))
(dm/assert! (cts/valid-shape-attrs? attrs))
(ptk/reify ::update-selected-shapes
ptk/WatchEvent
(watch [_ state _]
@ -742,7 +743,7 @@
;; Unmask groups whose mask have moved outside
(pcb/update-shapes groups-to-unmask
(fn [shape]
(assoc shape :masked-group? false)))
(assoc shape :masked-group false)))
;; Detach shapes moved out of their component
(pcb/update-shapes shapes-to-detach ctk/detach-shape)
@ -750,12 +751,12 @@
;; Make non root a component moved inside another one
(pcb/update-shapes shapes-to-deroot
(fn [shape]
(assoc shape :component-root? nil)))
(assoc shape :component-root nil)))
;; Make root a subcomponent moved outside its parent component
(pcb/update-shapes shapes-to-reroot
(fn [shape]
(assoc shape :component-root? true)))
(assoc shape :component-root true)))
;; Reset constraints depending on the new parent
(pcb/update-shapes shapes-to-unconstraint
@ -855,7 +856,7 @@
;; removed, and it must be converted to a normal group.
(let [obj (get objects id)
parent (get objects (:parent-id obj))]
(if (and (:masked-group? parent)
(if (and (:masked-group parent)
(= id (first (:shapes parent)))
(not= (:id parent) parent-id))
(conj group-ids (:id parent))
@ -990,8 +991,8 @@
(defn- move-shape
[shape]
(let [bbox (-> shape :points gsh/points->selrect)
pos (gpt/point (:x bbox) (:y bbox))]
(let [bbox (-> shape :points grc/points->rect)
pos (gpt/point (:x bbox) (:y bbox))]
(dwt/update-position (:id shape) pos)))
(defn align-objects
@ -1003,20 +1004,18 @@
(ptk/reify ::align-objects
ptk/WatchEvent
(watch [_ state _]
(let [page-id (:current-page-id state)
objects (wsh/lookup-page-objects state page-id)
(let [objects (wsh/lookup-page-objects state)
selected (wsh/lookup-selected state)
moved (if (= 1 (count selected))
(align-object-to-parent objects (first selected) axis)
(align-objects-list objects selected axis))
ids (map :id moved)
undo-id (js/Symbol)]
undo-id (js/Symbol)]
(when (can-align? selected objects)
(rx/concat
(rx/of (dwu/start-undo-transaction undo-id))
(->> (rx/from moved)
(rx/map move-shape))
(rx/of (ptk/data-event :layout/update ids)
(rx/of (ptk/data-event :layout/update (mapv :id moved))
(dwu/commit-undo-transaction undo-id))))))))
(defn align-object-to-parent
@ -1029,7 +1028,7 @@
(defn align-objects-list
[objects selected axis]
(let [selected-objs (map #(get objects %) selected)
rect (gsh/selection-rect selected-objs)]
rect (gsh/shapes->rect selected-objs)]
(mapcat #(gal/align-to-rect % rect axis objects) selected-objs)))
(defn can-distribute? [selected]
@ -1671,7 +1670,7 @@
selected-objs (map #(get paste-objects %) selected)
first-selected-obj (first selected-objs)
page-selected (wsh/lookup-selected state)
wrapper (gsh/selection-rect selected-objs)
wrapper (gsh/shapes->rect selected-objs)
orig-pos (gpt/point (:x1 wrapper) (:y1 wrapper))
frame-id (first page-selected)
frame-object (get page-objects frame-id)
@ -1716,22 +1715,25 @@
margin-y (-> (- (:height origin-frame-object) (+ (:y wrapper) (:height wrapper)))
(min (- (:height frame-object) (:height wrapper))))
;; Pasted objects mustn't exceed the selected frame x limit
;; Pasted objects mustn't exceed the selected frame x limit
paste-x (if (> (+ (:width wrapper) (:x1 wrapper)) (:width frame-object))
(+ (- (:x frame-object) (:x orig-pos)) (- (:width frame-object) (:width wrapper) margin-x))
(:x frame-object))
;; Pasted objects mustn't exceed the selected frame y limit
;; Pasted objects mustn't exceed the selected frame y limit
paste-y (if (> (+ (:height wrapper) (:y1 wrapper)) (:height frame-object))
(+ (- (:y frame-object) (:y orig-pos)) (- (:height frame-object) (:height wrapper) margin-y))
(:y frame-object))
delta (if (= origin-frame-id uuid/zero)
;; When the origin isn't in a frame the result is pasted in the center.
(gpt/subtract (gsh/center-shape frame-object) (gsh/center-selrect wrapper))
;; When pasting from one frame to another frame the object position must be limited to container boundaries. If the pasted object doesn't fit we try to:
;; - Align it to the limits on the x and y axis
;; - Respect the distance of the object to the right and bottom in the original frame
;; When the origin isn't in a frame the result is pasted in the center.
(gpt/subtract (gsh/shape->center frame-object) (grc/rect->center wrapper))
;; When pasting from one frame to another frame the object
;; position must be limited to container boundaries. If
;; the pasted object doesn't fit we try to:
;;
;; - Align it to the limits on the x and y axis
;; - Respect the distance of the object to the right and bottom in the original frame
(gpt/point paste-x paste-y))]
[frame-id frame-id delta]))
@ -1797,10 +1799,9 @@
(-> shape
(assoc :frame-id frame-id :parent-id parent-id)
(cond-> detach?
(->
;; this is used later, if the paste needs to create a new component from the detached shape
(assoc :saved-component-root? (:component-root? shape))
ctk/detach-shape))
;; this is used later, if the paste needs to create a new component from the detached shape
(-> (assoc :saved-component-root (:component-root shape))
(ctk/detach-shape)))
;; if is a text, remove references to external typographies
(cond-> (= (:type shape) :text)
(ctt/remove-external-typographies file-id)))))
@ -1876,7 +1877,7 @@
page-objects (wsh/lookup-page-objects state)
frame-id (first page-selected)
frame-object (get page-objects frame-id)]
(gsh/center-shape frame-object))
(gsh/shape->center frame-object))
:else
(deref ms/mouse-position)))
@ -2057,6 +2058,7 @@
(log/error :msg (str "Error removing " (:name media-obj))
:hint (ex-message %)
:error %)
(js/console.log (.-stack %))
(rx/of (error-in-remove-graphics)))))))
(defn- remove-graphics
@ -2076,10 +2078,8 @@
media (vals (:media file-data'))
media-points
(map #(assoc % :points (gsh/rect->points {:x 0
:y 0
:width (:width %)
:height (:height %)}))
(map #(assoc % :points (-> (grc/make-rect 0 0 (:width %) (:height %))
(grc/rect->points)))
media)
shape-grid

4
frontend/src/app/main/data/workspace/changes.cljs
View File

@ -207,8 +207,8 @@
(try
(dm/assert!
"expect valid vector of changes"
(and (cpc/changes? redo-changes)
(cpc/changes? undo-changes)))
(and (cpc/valid-changes? redo-changes)
(cpc/valid-changes? undo-changes)))
(update-in state path (fn [file]
(-> file

91
frontend/src/app/main/data/workspace/drawing.cljs
View File

@ -7,7 +7,7 @@
(ns app.main.data.workspace.drawing
"Drawing interactions."
(:require
[app.common.types.shape :as cts]
[app.common.data.macros :as dm]
[app.common.uuid :as uuid]
[app.main.data.workspace.common :as dwc]
[app.main.data.workspace.drawing.box :as box]
@ -23,44 +23,43 @@
;; --- Select for Drawing
(defn select-for-drawing
([tool] (select-for-drawing tool nil))
([tool data]
(ptk/reify ::select-for-drawing
ptk/UpdateEvent
(update [_ state]
(-> state
(update :workspace-drawing assoc :tool tool :object data)
;; When changing drawing tool disable "scale text" mode
;; automatically, to help users that ignore how this
;; mode works.
(update :workspace-layout disj :scale-text)))
[tool]
(ptk/reify ::select-for-drawing
ptk/UpdateEvent
(update [_ state]
(-> state
(update :workspace-drawing assoc :tool tool)
;; When changing drawing tool disable "scale text" mode
;; automatically, to help users that ignore how this
;; mode works.
(update :workspace-layout disj :scale-text)))
ptk/WatchEvent
(watch [_ _ stream]
(rx/merge
(when (= tool :path)
(rx/of (start-drawing :path)))
ptk/WatchEvent
(watch [_ _ stream]
(rx/merge
(when (= tool :path)
(rx/of (start-drawing :path)))
(when (= tool :curve)
(let [stopper (->> stream (rx/filter dwc/interrupt?))]
(->> stream
(rx/filter (ptk/type? ::common/handle-finish-drawing))
(rx/take 1)
(rx/observe-on :async)
(rx/map #(select-for-drawing tool data))
(rx/take-until stopper))))
;; NOTE: comments are a special case and they manage they
;; own interrupt cycle.q
(when (and (not= tool :comments)
(not= tool :path))
(let [stopper (rx/filter (ptk/type? ::clear-drawing) stream)]
(->> stream
(rx/filter dwc/interrupt?)
(rx/take 1)
(rx/map common/clear-drawing)
(rx/take-until stopper)))))))))
(when (= tool :curve)
(let [stopper (rx/filter dwc/interrupt? stream)]
(->> stream
(rx/filter (ptk/type? ::common/handle-finish-drawing))
(rx/map (constantly tool))
(rx/take 1)
(rx/observe-on :async)
(rx/map select-for-drawing)
(rx/take-until stopper))))
;; NOTE: comments are a special case and they manage they
;; own interrupt cycle.
(when (and (not= tool :comments)
(not= tool :path))
(let [stopper (rx/filter (ptk/type? ::clear-drawing) stream)]
(->> stream
(rx/filter dwc/interrupt?)
(rx/take 1)
(rx/map common/clear-drawing)
(rx/take-until stopper))))))))
;; NOTE/TODO: when an exception is raised in some point of drawing the
;; draw lock is not released so the user need to refresh in order to
@ -68,7 +67,7 @@
(defn start-drawing
[type]
{:pre [(keyword? type)]}
(dm/assert! (keyword? type))
(let [lock-id (uuid/next)]
(ptk/reify ::start-drawing
ptk/UpdateEvent
@ -77,7 +76,7 @@
ptk/WatchEvent
(watch [_ state stream]
(let [lock (get-in state [:workspace-drawing :lock])]
(let [lock (dm/get-in state [:workspace-drawing :lock])]
(when (= lock lock-id)
(rx/merge
(rx/of (handle-drawing type))
@ -89,23 +88,13 @@
(defn handle-drawing
[type]
(ptk/reify ::handle-drawing
ptk/UpdateEvent
(update [_ state]
(let [data (cts/make-minimal-shape type)]
(update-in state [:workspace-drawing :object] merge data)))
ptk/WatchEvent
(watch [_ _ _]
(rx/of
(case type
:path
(path/handle-new-shape)
:curve
(curve/handle-drawing-curve)
;; default
(box/handle-drawing-box))))))
:path (path/handle-new-shape)
:curve (curve/handle-drawing)
(box/handle-drawing type))))))

106
frontend/src/app/main/data/workspace/drawing/box.cljs
View File

@ -6,12 +6,13 @@
(ns app.main.data.workspace.drawing.box
(:require
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.geom.shapes.flex-layout :as gslf]
[app.common.geom.shapes.grid-layout :as gslg]
[app.common.math :as mth]
[app.common.pages.helpers :as cph]
[app.common.types.modifiers :as ctm]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
@ -42,13 +43,16 @@
(defn resize-shape [{:keys [x y width height] :as shape} initial point lock?]
(if (and (some? x) (some? y) (some? width) (some? height))
(let [draw-rect (gsh/make-rect initial (cond-> point lock? (adjust-ratio initial)))
shape-rect (gsh/make-rect x y width height)
(let [draw-rect (grc/make-rect initial (cond-> point lock? (adjust-ratio initial)))
shape-rect (grc/make-rect x y width height)
scalev (gpt/point (/ (:width draw-rect) (:width shape-rect))
(/ (:height draw-rect) (:height shape-rect)))
scalev (gpt/point (/ (:width draw-rect)
(:width shape-rect))
(/ (:height draw-rect)
(:height shape-rect)))
movev (gpt/to-vec (gpt/point shape-rect) (gpt/point draw-rect))]
movev (gpt/to-vec (gpt/point shape-rect)
(gpt/point draw-rect))]
(-> shape
(assoc :click-draw? false)
@ -65,24 +69,24 @@
(fn [state]
(update-in state [:workspace-drawing :object] gsh/absolute-move (gpt/point x y))))
(defn handle-drawing-box []
(ptk/reify ::handle-drawing-box
(defn handle-drawing
[type]
(ptk/reify ::handle-drawing
ptk/WatchEvent
(watch [_ state stream]
(let [stoper? #(or (ms/mouse-up? %) (= % :interrupt))
stoper (rx/filter stoper? stream)
layout (get state :workspace-layout)
zoom (get-in state [:workspace-local :zoom] 1)
snap-pixel? (contains? layout :snap-pixel-grid)
(let [stoper (rx/filter #(or (ms/mouse-up? %) (= % :interrupt)) stream)
layout (get state :workspace-layout)
zoom (dm/get-in state [:workspace-local :zoom] 1)
snap-precision (if (>= zoom zoom-half-pixel-precision) 0.5 1)
initial (cond-> @ms/mouse-position snap-pixel? (gpt/round-step snap-precision))
snap-pixel? (contains? layout :snap-pixel-grid)
snap-prec (if (>= zoom zoom-half-pixel-precision) 0.5 1)
initial (cond-> @ms/mouse-position snap-pixel? (gpt/round-step snap-prec))
page-id (:current-page-id state)
objects (wsh/lookup-page-objects state page-id)
focus (:workspace-focus-selected state)
page-id (:current-page-id state)
objects (wsh/lookup-page-objects state page-id)
focus (:workspace-focus-selected state)
fid (ctst/top-nested-frame objects initial)
fid (ctst/top-nested-frame objects initial)
flex-layout? (ctl/flex-layout? objects fid)
grid-layout? (ctl/grid-layout? objects fid)
@ -90,47 +94,41 @@
drop-index (when flex-layout? (gslf/get-drop-index fid objects initial))
drop-cell (when grid-layout? (gslg/get-drop-cell fid objects initial))
shape (get-in state [:workspace-drawing :object])
shape (-> shape
(cts/setup-shape {:x (:x initial)
:y (:y initial)
:width 0.01
:height 0.01})
(cond-> (and (cph/frame-shape? shape)
(not= fid uuid/zero))
(assoc :fills [] :hide-in-viewer true))
shape (-> (cts/setup-shape {:type type
:x (:x initial)
:y (:y initial)
:frame-id fid
:parent-id fid
:initialized? true
:click-draw? true
:hide-in-viewer (and (= type :frame) (not= fid uuid/zero))})
(cond-> (some? drop-index)
(with-meta {:index drop-index}))
(cond-> (some? drop-cell)
(with-meta {:cell drop-cell})))
(assoc :frame-id fid)
]
(cond-> (some? drop-index)
(with-meta {:index drop-index}))
(cond-> (some? drop-cell)
(with-meta {:cell drop-cell}))
(assoc :initialized? true)
(assoc :click-draw? true))]
(rx/concat
;; Add shape to drawing state
(rx/of #(assoc-in state [:workspace-drawing :object] shape))
(rx/of #(update % :workspace-drawing assoc :object shape))
;; Initial SNAP
(->>
(rx/concat
(->> (snap/closest-snap-point page-id [shape] objects layout zoom focus initial)
(rx/map move-drawing))
(->> (rx/concat
(->> (snap/closest-snap-point page-id [shape] objects layout zoom focus initial)
(rx/map move-drawing))
(->> ms/mouse-position
(rx/filter #(> (gpt/distance % initial) (/ 2 zoom)))
(rx/with-latest vector ms/mouse-position-shift)
(rx/switch-map
(fn [[point :as current]]
(->> (snap/closest-snap-point page-id [shape] objects layout zoom focus point)
(rx/map #(conj current %)))))
(rx/map
(fn [[_ shift? point]]
#(update-drawing % initial (cond-> point snap-pixel? (gpt/round-step snap-precision)) shift?)))))
(rx/take-until stoper))
(->> ms/mouse-position
(rx/filter #(> (gpt/distance % initial) (/ 2 zoom)))
(rx/with-latest vector ms/mouse-position-shift)
(rx/switch-map
(fn [[point :as current]]
(->> (snap/closest-snap-point page-id [shape] objects layout zoom focus point)
(rx/map #(conj current %)))))
(rx/map
(fn [[_ shift? point]]
#(update-drawing % initial (cond-> point snap-pixel? (gpt/round-step snap-prec)) shift?)))))
(rx/take-until stoper))
(->> (rx/of (common/handle-finish-drawing))
(rx/delay 100)))))))

35
frontend/src/app/main/data/workspace/drawing/common.cljs
View File

@ -6,6 +6,7 @@
(ns app.main.data.workspace.drawing.common
(:require
[app.common.data.macros :as dm]
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]
[app.common.pages.helpers :as cph]
@ -30,46 +31,46 @@
(ptk/reify ::handle-finish-drawing
ptk/WatchEvent
(watch [_ state _]
(let [tool (get-in state [:workspace-drawing :tool])
shape (get-in state [:workspace-drawing :object])
objects (wsh/lookup-page-objects state)]
(let [tool (dm/get-in state [:workspace-drawing :tool])
shape (dm/get-in state [:workspace-drawing :object])
objects (wsh/lookup-page-objects state)
page-id (:current-page-id state)]
(rx/concat
(when (:initialized? shape)
(let [page-id (:current-page-id state)
(let [click-draw? (:click-draw? shape)
text? (cph/text-shape? shape)
vbox (dm/get-in state [:workspace-local :vbox])
click-draw? (:click-draw? shape)
text? (= :text (:type shape))
min-side (min 100
(mth/floor (get-in state [:workspace-local :vbox :width]))
(mth/floor (get-in state [:workspace-local :vbox :height])))
min-side (mth/min 100
(mth/floor (dm/get-prop vbox :width))
(mth/floor (dm/get-prop vbox :height)))
shape
(cond-> shape
(not click-draw?)
(-> (assoc :grow-type :fixed))
(assoc :grow-type :fixed)
(and click-draw? (not text?))
(and ^boolean click-draw? (not ^boolean text?))
(-> (assoc :width min-side :height min-side)
(cts/setup-rect-selrect)
(cts/setup-shape)
(gsh/transform-shape (ctm/move-modifiers (- (/ min-side 2)) (- (/ min-side 2)))))
(and click-draw? text?)
(-> (assoc :height 17 :width 4 :grow-type :auto-width)
(cts/setup-rect-selrect))
(cts/setup-shape))
:always
(dissoc :initialized? :click-draw?))]
;; Add & select the created shape to the workspace
(rx/concat
(if (or (= :text (:type shape)) (= :frame (:type shape)))
(if (or (cph/text-shape? shape) (cph/frame-shape? shape))
(rx/of (dwu/start-undo-transaction (:id shape)))
(rx/empty))
(rx/of (dwsh/add-shape shape {:no-select? (= tool :curve)}))
(if (= :frame (:type shape))
(if (cph/frame-shape? shape)
(rx/concat
(->> (uw/ask! {:cmd :selection/query
:page-id page-id

128
frontend/src/app/main/data/workspace/drawing/curve.cljs
View File

@ -6,13 +6,17 @@
(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 :as gsh]
[app.common.geom.shapes.flex-layout :as gslf]
[app.common.geom.shapes.grid-layout :as gslg]
[app.common.geom.shapes.path :as gsp]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
[app.common.types.shape.layout :as ctl]
[app.common.uuid :as uuid]
[app.main.data.workspace.drawing.common :as common]
[app.main.data.workspace.state-helpers :as wsh]
[app.main.streams :as ms]
@ -22,85 +26,93 @@
(def simplify-tolerance 0.3)
(defn stoper-event? [{:keys [type] :as event}]
(defn stoper-event?
[{:keys [type] :as event}]
(ms/mouse-event? event) (= type :up))
(defn initialize-drawing [state]
(assoc-in state [:workspace-drawing :object :initialized?] true))
(defn insert-point-segment [state point]
(let [segments (-> state
(get-in [:workspace-drawing :object :segments])
(or [])
(conj point))
content (gsp/segments->content segments)
selrect (gsh/content->selrect content)
points (gsh/rect->points selrect)]
(-> state
(update-in [:workspace-drawing :object] assoc
:segments segments
:content content
:selrect selrect
:points points))))
(defn setup-frame-curve []
(ptk/reify ::setup-frame-path
(defn- insert-point
[point]
(ptk/reify ::insert-point
ptk/UpdateEvent
(update [_ state]
(update-in state [:workspace-drawing :object]
(fn [object]
(let [segments (-> (:segments object)
(conj point))
content (gsp/segments->content segments)
selrect (gsh/content->selrect content)
points (grc/rect->points selrect)]
(-> object
(assoc :segments segments)
(assoc :content content)
(assoc :selrect selrect)
(assoc :points points))))))))
(defn- setup-frame
[]
(ptk/reify ::setup-frame
ptk/UpdateEvent
(update [_ state]
(let [objects (wsh/lookup-page-objects state)
content (get-in state [:workspace-drawing :object :content] [])
start (get-in content [0 :params] nil)
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)
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))]
(-> state
(assoc-in [:workspace-drawing :object :frame-id] frame-id)
(cond-> (some? drop-index)
(update-in [:workspace-drawing :object] with-meta {:index drop-index}))
(cond-> (some? drop-cell)
(update-in [:workspace-drawing :object] with-meta {:cell drop-cell})))))))
(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})))))))))
(defn curve-to-path [{:keys [segments] :as shape}]
(let [content (gsp/segments->content segments)
selrect (gsh/content->selrect content)
points (gsh/rect->points selrect)]
(-> shape
(dissoc :segments)
(assoc :content content)
(assoc :selrect selrect)
(assoc :points points)
(cond-> (or (empty? points) (nil? selrect) (<= (count content) 1))
(assoc :initialized? false)))))
(defn finish-drawing-curve
(defn finish-drawing
[]
(ptk/reify ::finish-drawing-curve
(ptk/reify ::finish-drawing
ptk/UpdateEvent
(update [_ state]
(letfn [(update-curve [shape]
(-> shape
(update :segments #(ups/simplify % simplify-tolerance))
(curve-to-path)))]
(-> state
(update-in [:workspace-drawing :object] update-curve))))))
(update-in state [:workspace-drawing :object]
(fn [{:keys [segments] :as shape}]
(let [segments (ups/simplify segments simplify-tolerance)
content (gsp/segments->content segments)
selrect (gsh/content->selrect content)
points (grc/rect->points selrect)]
(-> shape
(dissoc :segments)
(assoc :content content)
(assoc :selrect selrect)
(assoc :points points)
(cond-> (or (empty? points)
(nil? selrect)
(<= (count content) 1))
(assoc :initialized? false)))))))))
(defn handle-drawing-curve []
(ptk/reify ::handle-drawing-curve
(defn handle-drawing []
(ptk/reify ::handle-drawing
ptk/WatchEvent
(watch [_ _ stream]
(let [stoper (rx/filter stoper-event? stream)
mouse (rx/sample 10 ms/mouse-position)]
mouse (rx/sample 10 ms/mouse-position)
shape (cts/setup-shape {:type :path
:initialized? true
:frame-id uuid/zero
:parent-id uuid/zero
:segments []})]
(rx/concat
(rx/of initialize-drawing)
(rx/of #(update % :workspace-drawing assoc :object shape))
(->> mouse
(rx/map (fn [pt] #(insert-point-segment % pt)))
(rx/map insert-point)
(rx/take-until stoper))
(rx/of (setup-frame-curve)
(finish-drawing-curve)
(common/handle-finish-drawing)))))))
(rx/of
(setup-frame)
(finish-drawing)
(common/handle-finish-drawing)))))))

4
frontend/src/app/main/data/workspace/grid_layout/editor.cljs
View File

@ -6,7 +6,7 @@
(ns app.main.data.workspace.grid-layout.editor
(:require
[app.common.geom.shapes :as gsh]
[app.common.geom.rect :as grc]
[app.main.data.workspace.state-helpers :as wsh]
[potok.core :as ptk]))
@ -58,7 +58,7 @@
(let [{:keys [x y width height]} srect
x (+ x (/ width 2) (- (/ (:width vport) 2 zoom)))
y (+ y (/ height 2) (- (/ (:height vport) 2 zoom)))
srect (gsh/make-selrect x y width height)]
srect (grc/make-rect x y width height)]
(-> local
(update :vbox merge (select-keys srect [:x :y :x1 :x2 :y1 :y2])))))))))))

20
frontend/src/app/main/data/workspace/groups.cljs
View File

@ -80,18 +80,20 @@
(:name (first shapes))
base-name)
selrect (gsh/selection-rect shapes)
selrect (gsh/shapes->rect shapes)
group-idx (->> shapes
last
:id
(cph/get-position-on-parent objects)
inc)
group (-> (cts/make-minimal-group frame-id selrect gname)
(cts/setup-shape selrect)
(assoc :shapes (mapv :id shapes)
:parent-id parent-id
:frame-id frame-id
:index group-idx))
group (cts/setup-shape {:type :group
:name gname
:shapes (mapv :id shapes)
:selrect selrect
:parent-id parent-id
:frame-id frame-id
:index group-idx})
;; Shapes that are in a component, but are not root, must be detached,
;; because they will be now children of a non instance group.
@ -290,7 +292,7 @@
(pcb/update-shapes [(:id group)]
(fn [group]
(assoc group
:masked-group? true
:masked-group true
:selrect (:selrect first-shape)
:points (:points first-shape)
:transform (:transform first-shape)
@ -319,7 +321,7 @@
(-> changes
(pcb/update-shapes [(:id mask)]
(fn [shape]
(dissoc shape :masked-group?)))
(dissoc shape :masked-group)))
(pcb/resize-parents [(:id mask)])))
(-> (pcb/empty-changes it page-id)
(pcb/with-objects objects))

6
frontend/src/app/main/data/workspace/interactions.cljs
View File

@ -8,8 +8,8 @@
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.files.helpers :as cfh]
[app.common.geom.point :as gpt]
[app.common.pages :as cp]
[app.common.pages.changes-builder :as pcb]
[app.common.pages.helpers :as cph]
[app.common.types.page :as ctp]
@ -33,8 +33,8 @@
(let [page (wsh/lookup-page state)
flows (get-in page [:options :flows] [])
unames (into #{} (map :name flows))
name (cp/generate-unique-name unames "Flow 1")
unames (cfh/get-used-names flows)
name (cfh/generate-unique-name unames "Flow 1")
new-flow {:id (uuid/next)
:name name

37
frontend/src/app/main/data/workspace/libraries.cljs
View File

@ -24,9 +24,11 @@
[app.common.uuid :as uuid]
[app.main.data.events :as ev]
[app.main.data.messages :as msg]
[app.main.data.workspace :as-alias dw]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.groups :as dwg]
[app.main.data.workspace.libraries-helpers :as dwlh]
[app.main.data.workspace.notifications :as-alias dwn]
[app.main.data.workspace.selection :as dws]
[app.main.data.workspace.shapes :as dwsh]
[app.main.data.workspace.state-helpers :as wsh]
@ -562,7 +564,7 @@
(defn ext-library-changed
[file-id modified-at revn changes]
(dm/assert! (uuid? file-id))
(dm/assert! (ch/changes? changes))
(dm/assert! (ch/valid-changes? changes))
(ptk/reify ::ext-library-changed
ptk/UpdateEvent
(update [_ state]
@ -901,11 +903,11 @@
(ptk/reify ::watch-component-changes
ptk/WatchEvent
(watch [_ state stream]
(let [components-v2 (features/active-feature? state :components-v2)
(let [components-v2? (features/active-feature? state :components-v2)
stopper
(->> stream
(rx/filter #(or (= :app.main.data.workspace/finalize-page (ptk/type %))
(rx/filter #(or (= ::dw/finalize-page (ptk/type %))
(= ::watch-component-changes (ptk/type %)))))
workspace-data-s
@ -914,35 +916,36 @@
(rx/from-atom refs/workspace-data {:emit-current-value? true}))
;; Need to get the file data before the change, so deleted shapes
;; still exist, for example
(rx/buffer 3 1))
(rx/buffer 3 1)
(rx/filter (fn [[old-data]] (some? old-data))))
change-s
(->> stream
(rx/filter #(or (dch/commit-changes? %)
(= (ptk/type %) :app.main.data.workspace.notifications/handle-file-change)))
(ptk/type? % ::dwn/handle-file-change)))
(rx/observe-on :async))
check-changes
(fn [[event [old-data _mid_data _new-data]]]
(when old-data
(let [{:keys [file-id changes save-undo? undo-group]}
(deref event)
(let [{:keys [file-id changes save-undo? undo-group]} (deref event)
components-changed
changed-components
(when (or (nil? file-id) (= file-id (:id old-data)))
(reduce #(into %1 (ch/components-changed old-data %2))
#{}
changes))]
(->> changes
(map (partial ch/components-changed old-data))
(reduce into #{})))]
(when (and (d/not-empty? components-changed) save-undo?)
(when (and (d/not-empty? changed-components) save-undo?)
(log/info :msg "DETECTED COMPONENTS CHANGED"
:ids (map str components-changed)
:ids (map str changed-components)
:undo-group undo-group)
(run! st/emit!
(map #(launch-component-sync % (:id old-data) undo-group)
components-changed))))))]
(when components-v2
(->> changed-components
(map #(launch-component-sync % (:id old-data) undo-group))
(run! st/emit!))))))]
(when components-v2?
(->> change-s
(rx/with-latest-from workspace-data-s)
(rx/map check-changes)

44
frontend/src/app/main/data/workspace/libraries_helpers.cljs
View File

@ -11,7 +11,6 @@
[app.common.geom.point :as gpt]
[app.common.geom.shapes :as gsh]
[app.common.logging :as log]
[app.common.pages :as cp]
[app.common.pages.changes-builder :as pcb]
[app.common.pages.helpers :as cph]
[app.common.spec :as us]
@ -75,8 +74,8 @@
[(assoc root
:component-id new-id
:component-file file-id
:component-root? true
:main-instance? true)]]))
:component-root true
:main-instance true)]]))
changes (-> changes
(pcb/add-component (:id root-shape)
@ -136,7 +135,7 @@
position (gpt/point (:x main-instance-shape) (:y main-instance-shape))
component-instance-extra-data (if components-v2 {:main-instance? true} {})
component-instance-extra-data (if components-v2 {:main-instance true} {})
[new-instance-shape new-instance-shapes]
(when (and (some? main-instance-page) (some? main-instance-shape))
@ -181,8 +180,9 @@
(not (nil? parent-id))
(assoc :parent-id parent-id))
;; on copy/paste old id is used later to reorder the paster layers
changes (cond-> (pcb/add-object changes first-shape {:ignore-touched true})
(some? old-id) (pcb/amend-last-change #(assoc % :old-id old-id))) ; on copy/paste old id is used later to reorder the paster layers
(some? old-id) (pcb/amend-last-change #(assoc % :old-id old-id)))
changes (reduce #(pcb/add-object %1 %2 {:ignore-touched true})
changes
@ -204,7 +204,7 @@
(let [shape (ctn/get-shape container shape-id)]
(if (and (ctk/instance-head? shape) (not first))
;; Subinstances are not detached, but converted in top instances
(pcb/update-shapes changes [(:id shape)] #(assoc % :component-root? true))
(pcb/update-shapes changes [(:id shape)] #(assoc % :component-root true))
;; Otherwise, detach the shape and all children
(let [children-ids (:shapes shape)]
(reduce #(generate-detach-recursive %1 container %2 false)
@ -499,7 +499,7 @@
;; * IF THE INITIAL SHAPE IS THE SUBINSTANCE, the sync is done against
;; the remote component. Therefore, IShape-2-2-1 is synched with
;; Shape-1-1. Then the "touched" flags are reset, and the
;; "remote-synced?" flag is set (it will be set until the shape is
;; "remote-synced" flag is set (it will be set until the shape is
;; touched again or it's synced forced normal or inverse with the
;; near component).
;;
@ -509,19 +509,19 @@
;; cleared. Then, the "touched" flags THAT ARE TRUE are copied to
;; Shape-2-2-1. This may cause that Shape-2-2-1 is now touched respect
;; to Shape-1-1, and so, some attributes are not copied in a subsequent
;; normal sync. Or, if "remote-synced?" flag is set in IShape-2-2-1,
;; all touched flags are cleared in Shape-2-2-1 and "remote-synced?"
;; normal sync. Or, if "remote-synced" flag is set in IShape-2-2-1,
;; all touched flags are cleared in Shape-2-2-1 and "remote-synced"
;; is removed.
;;
;; * IN AN INVERSE SYNC INITIATED IN THE SUBINSTANCE, the update is done
;; to the remote component. E.g. IShape-2-2-1 attributes are copied into
;; Shape-1-1, and then touched cleared and "remote-synced?" flag set.
;; Shape-1-1, and then touched cleared and "remote-synced" flag set.
;;
;; #### WARNING: there are two conditions that are invisible to user:
;; - When the near shape (Shape-2-2-1) is touched respect the remote
;; one (Shape-1-1), there is no asterisk displayed anywhere.
;; - When the instance shape (IShape-2-2-1) is synced with the remote
;; shape (remote-synced? = true), the user will see that this shape
;; shape (remote-synced = true), the user will see that this shape
;; is different than the one in the near component (Shape-2-2-1)
;; but it's not touched.
@ -540,7 +540,7 @@
shape-main (when component
(ctf/get-ref-shape library component shape-inst))
initial-root? (:component-root? shape-inst)
initial-root? (:component-root shape-inst)
root-inst shape-inst
root-main (when component
@ -673,7 +673,7 @@
component (ctkl/get-component library (:component-id shape-inst))
shape-main (ctf/get-ref-shape library component shape-inst)
initial-root? (:component-root? shape-inst)
initial-root? (:component-root shape-inst)
root-inst shape-inst
root-main (ctf/get-component-root library component)]
@ -867,7 +867,7 @@
(assoc :shape-ref (:id original-shape))
set-remote-synced?
(assoc :remote-synced? true))))
(assoc :remote-synced true))))
update-original-shape (fn [original-shape _new-shape]
original-shape)
@ -967,8 +967,8 @@
:attr :component-file
:val (:component-file shape')}
{:type :set
:attr :component-root?
:val (:component-root? shape')}
:attr :component-root
:val (:component-root shape')}
{:type :set
:attr :shape-ref
:val (:shape-ref shape')}
@ -1087,7 +1087,7 @@
reset-touched?
nil
copy-touched?
(if (:remote-synced? origin-shape)
(if (:remote-synced origin-shape)
nil
(set/union
(:touched dest-shape)
@ -1117,7 +1117,7 @@
(log/info :msg (str "CHANGE-REMOTE-SYNCED? "
(if (cph/page? container) "[P] " "[C] ")
(:name shape))
:remote-synced? remote-synced?)
:remote-synced remote-synced?)
(-> changes
(update :redo-changes conj (make-change
container
@ -1125,14 +1125,14 @@
:id (:id shape)
:operations
[{:type :set-remote-synced
:remote-synced? remote-synced?}]}))
:remote-synced remote-synced?}]}))
(update :undo-changes d/preconj (make-change
container
{:type :mod-obj
:id (:id shape)
:operations
[{:type :set-remote-synced
:remote-synced? (:remote-synced? shape)}]}))))))
:remote-synced (:remote-synced shape)}]}))))))
(defn- update-attrs
"The main function that implements the attribute sync algorithm. Copy
@ -1158,7 +1158,7 @@
origin-shape (reposition-shape origin-shape origin-root dest-root)
touched (get dest-shape :touched #{})]
(loop [attrs (seq (keys cp/component-sync-attrs))
(loop [attrs (seq (keys ctk/sync-attrs))
roperations []
uoperations []]
@ -1196,7 +1196,7 @@
:val (get dest-shape attr)
:ignore-touched true}
attr-group (get cp/component-sync-attrs attr)]
attr-group (get ctk/sync-attrs attr)]
(if (or (= (get origin-shape attr) (get dest-shape attr))
(and (touched attr-group) omit-touched?))

42
frontend/src/app/main/data/workspace/media.cljs
View File

@ -259,27 +259,29 @@
"Convert a media object that contains a bitmap image into shapes,
one shape of type :image and one group that contains it."
[pos {:keys [name width height id mtype] :as media-obj}]
(let [group-shape (cts/make-shape :group
{:x (:x pos)
:y (:y pos)
:width width
:height height}
{:name name
:frame-id uuid/zero
:parent-id uuid/zero})
(let [group-shape (cts/setup-shape
{:type :group
:x (:x pos)
:y (:y pos)
:width width
:height height
:name name
:frame-id uuid/zero
:parent-id uuid/zero})
img-shape (cts/make-shape :image
{:x (:x pos)
:y (:y pos)
:width width
:height height
:metadata {:id id
:width width
:height height
:mtype mtype}}
{:name name
:frame-id uuid/zero
:parent-id (:id group-shape)})]
img-shape (cts/setup-shape
{:type :image
:x (:x pos)
:y (:y pos)
:width width
:height height
:metadata {:id id
:width width
:height height
:mtype mtype}
:name name
:frame-id uuid/zero
:parent-id (:id group-shape)})]
(rx/of [group-shape [img-shape]])))
(defn- add-shapes-and-component

27
frontend/src/app/main/data/workspace/modifiers.cljs
View File

@ -10,12 +10,13 @@
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]
[app.common.pages.common :as cpc]
[app.common.pages.helpers :as cph]
[app.common.types.container :as ctn]
[app.common.types.modifiers :as ctm]
[app.common.types.shape.attrs :refer [editable-attrs]]
[app.common.types.shape.layout :as ctl]
[app.main.constants :refer [zoom-half-pixel-precision]]
[app.main.data.workspace.changes :as dch]
@ -49,7 +50,7 @@
[shape root transformed-shape transformed-root objects modif-tree]
(let [root
(cond
(:component-root? shape)
(:component-root shape)
shape
(nil? root)
@ -59,7 +60,7 @@
transformed-root
(cond
(:component-root? transformed-shape)
(:component-root transformed-shape)
transformed-shape
(nil? transformed-root)
@ -376,21 +377,25 @@
(update [_ state]
(assoc state :workspace-modifiers (calculate-modifiers state ignore-constraints ignore-snap-pixel modif-tree params))))))
;; Rotation use different algorithm to calculate children modifiers (and do not use child constraints).
(def ^:private
xf-rotation-shape
(comp
(remove #(get % :blocked false))
(filter #(:rotation (get editable-attrs (:type %))))
(map :id)))
;; Rotation use different algorithm to calculate children
;; modifiers (and do not use child constraints).
(defn set-rotation-modifiers
([angle shapes]
(set-rotation-modifiers angle shapes (-> shapes gsh/selection-rect gsh/center-selrect)))
(set-rotation-modifiers angle shapes (-> shapes gsh/shapes->rect grc/rect->center)))
([angle shapes center]
(ptk/reify ::set-rotation-modifiers
ptk/UpdateEvent
(update [_ state]
(let [objects (wsh/lookup-page-objects state)
ids
(->> shapes
(remove #(get % :blocked false))
(filter #((cpc/editable-attrs (:type %)) :rotation))
(map :id))
(let [objects (wsh/lookup-page-objects state)
ids (sequence xf-rotation-shape shapes)
get-modifier
(fn [shape]

39
frontend/src/app/main/data/workspace/path/drawing.cljs
View File

@ -11,6 +11,7 @@
[app.common.geom.shapes.flex-layout :as gsl]
[app.common.path.commands :as upc]
[app.common.path.shapes-to-path :as upsp]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
[app.common.types.shape.layout :as ctl]
[app.main.data.workspace.changes :as dch]
@ -196,14 +197,13 @@
drag-events
(rx/of (finish-drag)))))))
(defn handle-drawing-path
(defn handle-drawing
[_id]
(ptk/reify ::handle-drawing-path
(ptk/reify ::handle-drawing
ptk/UpdateEvent
(update [_ state]
(let [id (st/get-path-id state)]
(-> state
(assoc-in [:workspace-local :edit-path id :edit-mode] :draw))))
(assoc-in state [:workspace-local :edit-path id :edit-mode] :draw)))
ptk/WatchEvent
(watch [_ _ stream]
@ -234,9 +234,8 @@
mousedown-events)
(rx/of (common/finish-path "after-events")))))))
(defn setup-frame-path []
(ptk/reify ::setup-frame-path
(defn setup-frame []
(ptk/reify ::setup-frame
ptk/UpdateEvent
(update [_ state]
(let [objects (wsh/lookup-page-objects state)
@ -245,10 +244,14 @@
frame-id (ctst/top-nested-frame objects position)
flex-layout? (ctl/flex-layout? objects frame-id)
drop-index (when flex-layout? (gsl/get-drop-index frame-id objects position))]
(-> state
(assoc-in [:workspace-drawing :object :frame-id] frame-id)
(cond-> (some? drop-index)
(update-in [:workspace-drawing :object] with-meta {:index drop-index})))))))
(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})))))))))
(defn handle-new-shape-result [shape-id]
(ptk/reify ::handle-new-shape-result
@ -264,7 +267,7 @@
(watch [_ state _]
(let [content (get-in state [:workspace-drawing :object :content] [])]
(if (seq content)
(rx/of (setup-frame-path)
(rx/of (setup-frame)
(dwdc/handle-finish-drawing)
(dwe/start-edition-mode shape-id)
(change-edit-mode :draw))
@ -276,15 +279,17 @@
(ptk/reify ::handle-new-shape
ptk/UpdateEvent
(update [_ state]
(let [id (st/get-path-id state)]
(let [id (st/get-path-id state)
shape (cts/setup-shape {:type :path})]
(-> state
(assoc-in [:workspace-local :edit-path id :snap-toggled] false))))
(assoc-in [:workspace-local :edit-path id :snap-toggled] false)
(update :workspace-drawing assoc :object shape))))
ptk/WatchEvent
(watch [_ state stream]
(let [shape-id (get-in state [:workspace-drawing :object :id])]
(let [shape-id (dm/get-in state [:workspace-drawing :object :id])]
(rx/concat
(rx/of (handle-drawing-path shape-id))
(rx/of (handle-drawing shape-id))
(->> stream
(rx/filter (ptk/type? ::common/finish-path))
(rx/take 1)
@ -310,7 +315,7 @@
(if (= :draw edit-mode)
(rx/concat
(rx/of (dch/update-shapes [id] upsp/convert-to-path))
(rx/of (handle-drawing-path id))
(rx/of (handle-drawing id))
(->> stream
(rx/filter (ptk/type? ::common/finish-path))
(rx/take 1)

11
frontend/src/app/main/data/workspace/path/helpers.cljs
View File

@ -8,6 +8,7 @@
(:require
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]
[app.common.path.commands :as upc]
@ -28,7 +29,7 @@
[content]
(-> content
gsh/content->selrect
gsh/center-selrect))
grc/rect->center))
(defn content->points+selrect
"Given the content of a shape, calculate its points and selrect"
@ -45,7 +46,7 @@
flip-y (gmt/scale (gpt/point 1 -1))
:always (gmt/multiply (:transform-inverse shape (gmt/matrix))))
center (or (gsh/center-shape shape)
center (or (gsh/shape->center shape)
(content-center content))
base-content (gsh/transform-content
@ -54,16 +55,16 @@
;; Calculates the new selrect with points given the old center
points (-> (gsh/content->selrect base-content)
(gsh/rect->points)
(grc/rect->points)
(gsh/transform-points center transform))
points-center (gsh/center-points points)
points-center (gsh/points->center points)
;; Points is now the selrect but the center is different so we can create the selrect
;; through points
selrect (-> points
(gsh/transform-points points-center transform-inverse)
(gsh/points->selrect))]
(grc/points->rect))]
[points selrect]))
(defn update-selrect

3
frontend/src/app/main/data/workspace/path/selection.cljs
View File

@ -7,6 +7,7 @@
(ns app.main.data.workspace.path.selection
(:require
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.main.data.workspace.common :as dwc]
[app.main.data.workspace.path.state :as st]
@ -116,7 +117,7 @@
(rx/concat
(->> ms/mouse-position
(rx/take-until stoper)
(rx/map #(gsh/points->rect [from-p %]))
(rx/map #(grc/points->rect [from-p %]))
(rx/filter (partial valid-rect? zoom))
(rx/map update-area-selection))

2
frontend/src/app/main/data/workspace/persistence.cljs
View File

@ -235,7 +235,7 @@
[file-id {:keys [revn changes]}]
(dm/assert! (uuid? file-id))
(dm/assert! (int? revn))
(dm/assert! (cpc/changes? changes))
(dm/assert! (cpc/valid-changes? changes))
(ptk/reify ::shapes-changes-persisted
ptk/UpdateEvent

83
frontend/src/app/main/data/workspace/selection.cljs
View File

@ -8,12 +8,14 @@
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.files.helpers :as cfh]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]
[app.common.pages :as cp]
[app.common.pages.changes-builder :as pcb]
[app.common.pages.focus :as cpf]
[app.common.pages.helpers :as cph]
[app.common.record :as cr]
[app.common.types.component :as ctk]
[app.common.types.file :as ctf]
[app.common.types.page :as ctp]
@ -54,33 +56,28 @@
(ptk/reify ::handle-area-selection
ptk/WatchEvent
(watch [_ state stream]
(let [zoom (get-in state [:workspace-local :zoom] 1)
stop? (fn [event] (or (interrupt? event) (ms/mouse-up? event)))
stoper (->> stream (rx/filter stop?))
(let [zoom (dm/get-in state [:workspace-local :zoom] 1)
stop? (fn [event] (or (interrupt? event) (ms/mouse-up? event)))
stoper (rx/filter stop? stream)
init-selrect
{:type :rect
:x1 (:x @ms/mouse-position)
:y1 (:y @ms/mouse-position)
:x2 (:x @ms/mouse-position)
:y2 (:y @ms/mouse-position)}
init-position @ms/mouse-position
init-selrect (grc/make-rect
(dm/get-prop init-position :x)
(dm/get-prop init-position :y)
0 0)
calculate-selrect
(fn [selrect [delta space?]]
(let [result
(cond-> selrect
:always
(-> (update :x2 + (:x delta))
(update :y2 + (:y delta)))
space?
(-> (update :x1 + (:x delta))
(update :y1 + (:y delta))))]
(assoc result
:x (min (:x1 result) (:x2 result))
:y (min (:y1 result) (:y2 result))
:width (mth/abs (- (:x2 result) (:x1 result)))
:height (mth/abs (- (:y2 result) (:y1 result))))))
(let [selrect (-> (cr/clone selrect)
(cr/update! :x2 + (:x delta))
(cr/update! :y2 + (:y delta)))
selrect (if ^boolean space?
(-> selrect
(cr/update! :x1 + (:x delta))
(cr/update! :y1 + (:y delta)))
selrect)]
(grc/update-rect! selrect :corners)))
selrect-stream
(->> ms/mouse-position
@ -89,9 +86,10 @@
(rx/filter some?)
(rx/with-latest-from ms/keyboard-space)
(rx/scan calculate-selrect init-selrect)
(rx/filter #(or (> (:width %) (/ 10 zoom))
(> (:height %) (/ 10 zoom))))
(rx/filter #(or (> (dm/get-prop % :width) (/ 10 zoom))
(> (dm/get-prop % :height) (/ 10 zoom))))
(rx/take-until stoper))]
(rx/concat
(if preserve?
(rx/empty)
@ -193,10 +191,10 @@
(shift-select-shapes id nil))
([id objects]
(ptk/reify ::shift-select-shapes-2
(ptk/reify ::shift-select-shapes
ptk/UpdateEvent
(update [_ state]
(let [objects (or objects (wsh/lookup-page-objects state))
(let [objects (or objects (wsh/lookup-page-objects state))
selection (-> state
wsh/lookup-selected
(conj id))]
@ -217,7 +215,7 @@
(let [objects (wsh/lookup-page-objects state)
focus (:workspace-focus-selected state)
ids (if (d/not-empty? focus)
(cp/filter-not-focus objects focus ids)
(cpf/filter-not-focus objects focus ids)
ids)]
(assoc-in state [:workspace-local :selected] ids)))
@ -236,7 +234,7 @@
;; mode is active
focus (:workspace-focus-selected state)
objects (-> (wsh/lookup-page-objects state)
(cp/focus-objects focus))
(cpf/focus-objects focus))
lookup (d/getf objects)
parents (->> (wsh/lookup-selected state)
@ -282,14 +280,15 @@
(ptk/reify ::select-shapes-by-current-selrect
ptk/WatchEvent
(watch [_ state _]
(let [page-id (:current-page-id state)
objects (wsh/lookup-page-objects state)
selected (wsh/lookup-selected state)
(let [page-id (:current-page-id state)
objects (wsh/lookup-page-objects state)
selected (wsh/lookup-selected state)
initial-set (if preserve?
selected
lks/empty-linked-set)
selrect (get-in state [:workspace-local :selrect])
blocked? (fn [id] (get-in objects [id :blocked] false))]
selrect (dm/get-in state [:workspace-local :selrect])
blocked? (fn [id] (dm/get-in objects [id :blocked] false))]
(when selrect
(rx/empty)
(->> (uw/ask-buffered!
@ -353,7 +352,7 @@
([all-objects page ids delta it libraries library-data file-id init-changes]
(let [shapes (map (d/getf all-objects) ids)
unames (volatile! (cp/retrieve-used-names (:objects page)))
unames (volatile! (cfh/get-used-names (:objects page)))
update-unames! (fn [new-name] (vswap! unames conj new-name))
all-ids (reduce #(into %1 (cons %2 (cph/get-children-ids all-objects %2))) (d/ordered-set) ids)
ids-map (into {} (map #(vector % (uuid/next))) all-ids)
@ -424,8 +423,8 @@
parent-id (or parent-id frame-id)
name (:name obj)
is-component-root? (:saved-component-root? obj)
is-component-main? (:main-instance? obj)
is-component-root? (:saved-component-root obj)
is-component-main? (:main-instance obj)
regenerate-component
(fn [changes shape]
(let [components-v2 (dm/get-in library-data [:options :components-v2])
@ -438,9 +437,9 @@
:parent-id parent-id
:frame-id frame-id)
(dissoc :shapes
:main-instance?
:main-instance
:shape-ref
:use-for-thumbnail?)
:use-for-thumbnail)
(gsh/move delta)
(d/update-when :interactions #(ctsi/remap-interactions % ids-map objects))
@ -486,7 +485,7 @@
(let [update-flows (fn [flows]
(reduce
(fn [flows frame]
(let [name (cp/generate-unique-name @unames "Flow 1")
(let [name (cfh/generate-unique-name @unames "Flow 1")
_ (vswap! unames conj name)
new-flow {:id (uuid/next)
:name name

2
frontend/src/app/main/data/workspace/shape_layout.cljs
View File

@ -93,7 +93,7 @@
(->> shapes
(map :id)
(ctt/sort-z-index objects)
(map (comp gsh/center-shape (d/getf objects))))
(map (comp gsh/shape->center (d/getf objects))))
start (first points)
end (reduce (fn [acc p] (gpt/add acc (gpt/to-vec start p))) points)

184
frontend/src/app/main/data/workspace/shapes.cljs
View File

@ -8,7 +8,6 @@
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.geom.proportions :as gpp]
[app.common.geom.shapes :as gsh]
[app.common.pages.changes-builder :as pcb]
[app.common.pages.helpers :as cph]
@ -28,61 +27,19 @@
[app.main.data.workspace.state-helpers :as wsh]
[app.main.data.workspace.undo :as dwu]
[app.main.features :as features]
[app.main.streams :as ms]
[beicon.core :as rx]
[potok.core :as ptk]))
(defn get-shape-layer-position
[objects selected attrs]
;; Calculate the frame over which we're drawing
(let [position @ms/mouse-position
frame-id (:frame-id attrs (ctst/top-nested-frame objects position))
shape (when-not (empty? selected)
(cph/get-base-shape objects selected))]
;; When no shapes has been selected or we're over a different frame
;; we add it as the latest shape of that frame
(if (or (not shape) (not= (:frame-id shape) frame-id))
[frame-id frame-id nil]
;; Otherwise, we add it to next to the selected shape
(let [index (cph/get-position-on-parent objects (:id shape))
{:keys [frame-id parent-id]} shape]
[frame-id parent-id (inc index)]))))
(defn make-new-shape
[attrs objects selected]
(let [default-attrs (if (= :frame (:type attrs))
cts/default-frame-attrs
cts/default-shape-attrs)
selected-non-frames
(into #{} (comp (map (d/getf objects))
(remove cph/frame-shape?))
selected)
[frame-id parent-id index]
(get-shape-layer-position objects selected-non-frames attrs)]
(-> (merge default-attrs attrs)
(gpp/setup-proportions)
(assoc :frame-id frame-id
:parent-id parent-id
:index index))))
(def valid-shape-map?
(sm/pred-fn ::cts/shape))
(defn prepare-add-shape
[changes attrs objects selected]
(let [id (or (:id attrs) (uuid/next))
name (:name attrs)
[changes shape objects _selected]
(let [index (:index (meta shape))
;; FIXME: revisit
id (:id shape)
shape (make-new-shape
(assoc attrs :id id :name name)
objects
selected)
index (:index (meta attrs))
[row column :as cell] (:cell (meta attrs))
[row column :as cell] (:cell (meta shape))
changes (-> changes
(pcb/with-objects objects)
@ -90,8 +47,8 @@
(pcb/add-object shape {:index index}))
(cond-> (nil? index)
(pcb/add-object shape))
(cond-> (some? (:parent-id attrs))
(pcb/change-parent (:parent-id attrs) [shape] index))
(cond-> (some? (:parent-id shape))
(pcb/change-parent (:parent-id shape) [shape] index))
(cond-> (some? cell)
(pcb/update-shapes [(:parent-id shape)] #(ctl/push-into-cell % [id] row column)))
(cond-> (ctl/grid-layout? objects (:parent-id shape))
@ -100,10 +57,14 @@
[shape changes]))
(defn add-shape
([attrs]
(add-shape attrs {}))
([attrs {:keys [no-select? no-update-layout?]}]
(dm/assert! (cts/shape-attrs? attrs))
([shape]
(add-shape shape {}))
([shape {:keys [no-select? no-update-layout?]}]
(dm/verify!
"expected a valid shape"
(cts/valid-shape? shape))
(ptk/reify ::add-shape
ptk/WatchEvent
(watch [it state _]
@ -111,11 +72,10 @@
objects (wsh/lookup-page-objects state page-id)
selected (wsh/lookup-selected state)
changes (-> (pcb/empty-changes it page-id)
(pcb/with-objects objects))
[shape changes]
(prepare-add-shape changes attrs objects selected)
(-> (pcb/empty-changes it page-id)
(pcb/with-objects objects)
(prepare-add-shape shape objects selected))
undo-id (js/Symbol)]
@ -127,7 +87,7 @@
(when-not no-select?
(dws/select-shapes (d/ordered-set (:id shape))))
(dwu/commit-undo-transaction undo-id))
(when (= :text (:type attrs))
(when (cph/text-shape? shape)
(->> (rx/of (dwe/start-edition-mode (:id shape)))
(rx/observe-on :async)))))))))
@ -183,7 +143,7 @@
components-v2 (features/active-feature? state :components-v2)
ids (cph/clean-loops objects ids)
ids (cph/clean-loops objects ids)
in-component-copy?
(fn [shape-id]
@ -237,7 +197,7 @@
;; converted to a normal group.
(let [obj (lookup id)
parent (lookup (:parent-id obj))]
(if (and (:masked-group? parent)
(if (and (:masked-group parent)
(= id (first (:shapes parent))))
(conj group-ids (:id parent))
group-ids)))
@ -305,7 +265,7 @@
(reduce (fn [components id]
(let [shape (get objects id)]
(if (and (= (:component-file shape) (:id file)) ;; Main instances should exist only in local file
(:main-instance? shape)) ;; but check anyway
(:main-instance shape)) ;; but check anyway
(conj components (:component-id shape))
components)))
[]
@ -329,7 +289,7 @@
(pcb/resize-parents all-parents)
(pcb/update-shapes groups-to-unmask
(fn [shape]
(assoc shape :masked-group? false)))
(assoc shape :masked-group false)))
(pcb/update-shapes (map :id interacting-shapes)
(fn [shape]
(d/update-when shape :interactions
@ -350,7 +310,6 @@
(let [[changes _all-parents] (real-delete-shapes-changes changes file page objects ids it components-v2)]
changes))
(defn- real-delete-shapes
[file page objects ids it components-v2]
(let [[changes all-parents] (real-delete-shapes-changes file page objects ids it components-v2)
@ -363,59 +322,78 @@
(defn create-and-add-shape
[type frame-x frame-y data]
[type frame-x frame-y {:keys [width height] :as attrs}]
(ptk/reify ::create-and-add-shape
ptk/WatchEvent
(watch [_ state _]
(let [{:keys [width height]} data
(let [vbc (wsh/viewport-center state)
x (:x attrs (- (:x vbc) (/ width 2)))
y (:y attrs (- (:y vbc) (/ height 2)))
page-id (:current-page-id state)
objects (wsh/lookup-page-objects state page-id)
frame-id (-> (wsh/lookup-page-objects state page-id)
(ctst/top-nested-frame {:x frame-x :y frame-y}))
vbc (wsh/viewport-center state)
x (:x data (- (:x vbc) (/ width 2)))
y (:y data (- (:y vbc) (/ height 2)))
page-id (:current-page-id state)
objects (wsh/lookup-page-objects state page-id)
frame-id (-> (wsh/lookup-page-objects state page-id)
(ctst/top-nested-frame {:x frame-x :y frame-y}))
selected (wsh/lookup-selected state)
page-objects (wsh/lookup-page-objects state)
base (cph/get-base-shape page-objects selected)
selected-frame? (and (= 1 (count selected))
(= :frame (get-in objects [(first selected) :type])))
parent-id (if
(or selected-frame? (empty? selected)) frame-id
(:parent-id base))
selected (wsh/lookup-selected state)
base (cph/get-base-shape objects selected)
parent-id (if (or (and (= 1 (count selected))
(cph/frame-shape? (get objects (first selected))))
(empty? selected))
frame-id
(:parent-id base))
shape (cts/setup-shape
(-> attrs
(assoc :type type)
(assoc :x x)
(assoc :y y)
(assoc :frame-id frame-id)
(assoc :parent-id parent-id)))]
shape (-> (cts/make-minimal-shape type)
(merge data)
(merge {:x x :y y})
(assoc :frame-id frame-id :parent-id parent-id)
(cts/setup-rect-selrect))]
(rx/of (add-shape shape))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Artboard
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FIXME: looks
(defn prepare-create-artboard-from-selection
[changes id parent-id objects selected index frame-name without-fill?]
(let [selected-objs (map #(get objects %) selected)
new-index (or index
(cph/get-index-replacement selected objects))]
(when (d/not-empty? selected)
(let [srect (gsh/selection-rect selected-objs)
frame-id (get-in objects [(first selected) :frame-id])
parent-id (or parent-id (get-in objects [(first selected) :parent-id]))
shape (-> (cts/make-minimal-shape :frame)
(merge {:x (:x srect) :y (:y srect) :width (:width srect) :height (:height srect)})
(cond-> id
(assoc :id id))
(cond-> frame-name
(assoc :name frame-name))
(assoc :frame-id frame-id :parent-id parent-id)
(with-meta {:index new-index})
(cond-> (or (not= frame-id uuid/zero) without-fill?)
(assoc :fills [] :hide-in-viewer true))
(cts/setup-rect-selrect))
(let [srect (gsh/shapes->rect selected-objs)
selected-id (first selected)
frame-id (dm/get-in objects [selected-id :frame-id])
parent-id (or parent-id (dm/get-in objects [selected-id :parent-id]))
attrs {:type :frame
:x (:x srect)
:y (:y srect)
:width (:width srect)
:height (:height srect)}
shape (cts/setup-shape
(cond-> attrs
(some? id)
(assoc :id id)
(some? frame-name)
(assoc :name frame-name)
:always
(assoc :frame-id frame-id
:parent-id parent-id)
:always
(with-meta {:index new-index})
(or (not= frame-id uuid/zero) without-fill?)
(assoc :fills [] :hide-in-viewer true)))
[shape changes]
(prepare-add-shape changes shape objects selected)
@ -476,7 +454,7 @@
(dm/assert!
"expected valid shape-attrs value for `flags`"
(cts/shape-attrs? flags))
(cts/valid-shape-attrs? flags))
(ptk/reify ::update-shape-flags
ptk/WatchEvent

584
frontend/src/app/main/data/workspace/svg_upload.cljs
View File

@ -8,21 +8,20 @@
(:require
[app.common.colors :as clr]
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.data.macros :as dm]
[app.common.files.helpers :as cfh]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]
[app.common.pages :as cp]
[app.common.pages.changes-builder :as pcb]
[app.common.pages.helpers :as cph]
[app.common.spec :as us :refer [max-safe-int min-safe-int]]
[app.common.schema :as sm :refer [max-safe-int min-safe-int]]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
[app.common.uuid :as uuid]
[app.main.data.workspace.changes :as dch]
[app.main.data.workspace.selection :as dws]
[app.main.data.workspace.shapes :as dwsh]
[app.main.data.workspace.state-helpers :as wsh]
[app.main.data.workspace.undo :as dwu]
[app.main.repo :as rp]
@ -34,19 +33,16 @@
[cuerdas.core :as str]
[potok.core :as ptk]))
(defonce default-rect {:x 0 :y 0 :width 1 :height 1 :rx 0 :ry 0})
(defonce default-circle {:r 0 :cx 0 :cy 0})
(defonce default-image {:x 0 :y 0 :width 1 :height 1 :rx 0 :ry 0})
(def default-rect
{:x 0 :y 0 :width 1 :height 1})
(defn- assert-valid-num [attr num]
(when-not (and (d/num? num)
(<= num max-safe-int)
(>= num min-safe-int))
(ex/raise :type :assertion
:code :expr-validation
:hint (str/ffmt "%1 attribute has invalid value: %2" (d/name attr) num)))
(dm/verify!
["%1 attribute has invalid value: %2" (d/name attr) num]
(and (d/num? num)
(<= num max-safe-int)
(>= num min-safe-int)))
;; If the number is between 0-1 we round to 1 (same in negative form
(cond
(and (> num 0) (< num 1)) 1
(and (< num 0) (> num -1)) -1
@ -54,28 +50,25 @@
(defn- assert-valid-pos-num
[attr num]
(when-not (pos? num)
(ex/raise :type :assertion
:code :expr-validation
:hint (str/ffmt "%1 attribute should be positive" (d/name attr))))
(dm/verify!
["%1 attribute should be positive" (d/name attr)]
(pos? num))
num)
(defn- assert-valid-blend-mode
[mode]
(let [clean-value (-> mode
str/trim
str/lower
keyword)]
(when-not (contains? cts/blend-modes clean-value)
(ex/raise :type :assertion
:code :expr-validation
:hint (str/ffmt "%1 is not a valid blend mode" clean-value)))
(let [clean-value (-> mode str/trim str/lower keyword)]
(dm/verify!
["%1 is not a valid blend mode" clean-value]
(contains? cts/blend-modes clean-value))
clean-value))
(defn- svg-dimensions [data]
(let [width (get-in data [:attrs :width] 100)
height (get-in data [:attrs :height] 100)
viewbox (get-in data [:attrs :viewBox] (str "0 0 " width " " height))
(let [width (dm/get-in data [:attrs :width] 100)
height (dm/get-in data [:attrs :height] 100)
viewbox (dm/get-in data [:attrs :viewBox] (str "0 0 " width " " height))
[x y width height] (->> (str/split viewbox #"\s+")
(map d/parse-double))
width (if (= width 0) 1 width)
@ -94,9 +87,9 @@
:else (str tag))))
(defn setup-fill [shape]
(let [color-attr (str/trim (get-in shape [:svg-attrs :fill]))
(let [color-attr (str/trim (dm/get-in shape [:svg-attrs :fill]))
color-attr (if (= color-attr "currentColor") clr/black color-attr)
color-style (str/trim (get-in shape [:svg-attrs :style :fill]))
color-style (str/trim (dm/get-in shape [:svg-attrs :style :fill]))
color-style (if (= color-style "currentColor") clr/black color-style)]
(cond-> shape
;; Color present as attribute
@ -111,26 +104,26 @@
(update :svg-attrs dissoc :fill)
(assoc-in [:fills 0 :fill-color] (uc/parse-color color-style)))
(get-in shape [:svg-attrs :fill-opacity])
(dm/get-in shape [:svg-attrs :fill-opacity])
(-> (update :svg-attrs dissoc :fill-opacity)
(update-in [:svg-attrs :style] dissoc :fill-opacity)
(assoc-in [:fills 0 :fill-opacity] (-> (get-in shape [:svg-attrs :fill-opacity])
(assoc-in [:fills 0 :fill-opacity] (-> (dm/get-in shape [:svg-attrs :fill-opacity])
(d/parse-double 1))))
(get-in shape [:svg-attrs :style :fill-opacity])
(dm/get-in shape [:svg-attrs :style :fill-opacity])
(-> (update-in [:svg-attrs :style] dissoc :fill-opacity)
(update :svg-attrs dissoc :fill-opacity)
(assoc-in [:fills 0 :fill-opacity] (-> (get-in shape [:svg-attrs :style :fill-opacity])
(assoc-in [:fills 0 :fill-opacity] (-> (dm/get-in shape [:svg-attrs :style :fill-opacity])
(d/parse-double 1)))))))
(defn setup-stroke [shape]
(let [stroke-linecap (-> (or (get-in shape [:svg-attrs :stroke-linecap])
(get-in shape [:svg-attrs :style :stroke-linecap]))
(let [stroke-linecap (-> (or (dm/get-in shape [:svg-attrs :stroke-linecap])
(dm/get-in shape [:svg-attrs :style :stroke-linecap]))
((d/nilf str/trim))
((d/nilf keyword)))
color-attr (str/trim (get-in shape [:svg-attrs :stroke]))
color-attr (str/trim (dm/get-in shape [:svg-attrs :stroke]))
color-attr (if (= color-attr "currentColor") clr/black color-attr)
color-style (str/trim (get-in shape [:svg-attrs :style :stroke]))
color-style (str/trim (dm/get-in shape [:svg-attrs :style :stroke]))
color-style (if (= color-style "currentColor") clr/black color-style)
shape
@ -145,24 +138,24 @@
(-> (update-in [:svg-attrs :style] dissoc :stroke)
(assoc-in [:strokes 0 :stroke-color] (uc/parse-color color-style)))
(get-in shape [:svg-attrs :stroke-opacity])
(dm/get-in shape [:svg-attrs :stroke-opacity])
(-> (update :svg-attrs dissoc :stroke-opacity)
(assoc-in [:strokes 0 :stroke-opacity] (-> (get-in shape [:svg-attrs :stroke-opacity])
(assoc-in [:strokes 0 :stroke-opacity] (-> (dm/get-in shape [:svg-attrs :stroke-opacity])
(d/parse-double 1))))
(get-in shape [:svg-attrs :style :stroke-opacity])
(dm/get-in shape [:svg-attrs :style :stroke-opacity])
(-> (update-in [:svg-attrs :style] dissoc :stroke-opacity)
(assoc-in [:strokes 0 :stroke-opacity] (-> (get-in shape [:svg-attrs :style :stroke-opacity])
(assoc-in [:strokes 0 :stroke-opacity] (-> (dm/get-in shape [:svg-attrs :style :stroke-opacity])
(d/parse-double 1))))
(get-in shape [:svg-attrs :stroke-width])
(dm/get-in shape [:svg-attrs :stroke-width])
(-> (update :svg-attrs dissoc :stroke-width)
(assoc-in [:strokes 0 :stroke-width] (-> (get-in shape [:svg-attrs :stroke-width])
(assoc-in [:strokes 0 :stroke-width] (-> (dm/get-in shape [:svg-attrs :stroke-width])
(d/parse-double))))
(get-in shape [:svg-attrs :style :stroke-width])
(dm/get-in shape [:svg-attrs :style :stroke-width])
(-> (update-in [:svg-attrs :style] dissoc :stroke-width)
(assoc-in [:strokes 0 :stroke-width] (-> (get-in shape [:svg-attrs :style :stroke-width])
(assoc-in [:strokes 0 :stroke-width] (-> (dm/get-in shape [:svg-attrs :style :stroke-width])
(d/parse-double))))
(and stroke-linecap (= (:type shape) :path))
@ -172,106 +165,111 @@
:stroke-cap-end stroke-linecap))))]
(cond-> shape
(d/any-key? (get-in shape [:strokes 0]) :stroke-color :stroke-opacity :stroke-width :stroke-cap-start :stroke-cap-end)
(d/any-key? (dm/get-in shape [:strokes 0]) :stroke-color :stroke-opacity :stroke-width :stroke-cap-start :stroke-cap-end)
(assoc-in [:strokes 0 :stroke-style] :svg))))
(defn setup-opacity [shape]
(cond-> shape
(get-in shape [:svg-attrs :opacity])
(dm/get-in shape [:svg-attrs :opacity])
(-> (update :svg-attrs dissoc :opacity)
(assoc :opacity (-> (get-in shape [:svg-attrs :opacity])
(assoc :opacity (-> (dm/get-in shape [:svg-attrs :opacity])
(d/parse-double 1))))
(get-in shape [:svg-attrs :style :opacity])
(dm/get-in shape [:svg-attrs :style :opacity])
(-> (update-in [:svg-attrs :style] dissoc :opacity)
(assoc :opacity (-> (get-in shape [:svg-attrs :style :opacity])
(assoc :opacity (-> (dm/get-in shape [:svg-attrs :style :opacity])
(d/parse-double 1))))
(get-in shape [:svg-attrs :mix-blend-mode])
(dm/get-in shape [:svg-attrs :mix-blend-mode])
(-> (update :svg-attrs dissoc :mix-blend-mode)
(assoc :blend-mode (-> (get-in shape [:svg-attrs :mix-blend-mode]) assert-valid-blend-mode)))
(assoc :blend-mode (-> (dm/get-in shape [:svg-attrs :mix-blend-mode]) assert-valid-blend-mode)))
(get-in shape [:svg-attrs :style :mix-blend-mode])
(dm/get-in shape [:svg-attrs :style :mix-blend-mode])
(-> (update-in [:svg-attrs :style] dissoc :mix-blend-mode)
(assoc :blend-mode (-> (get-in shape [:svg-attrs :style :mix-blend-mode]) assert-valid-blend-mode)))))
(assoc :blend-mode (-> (dm/get-in shape [:svg-attrs :style :mix-blend-mode]) assert-valid-blend-mode)))))
(defn create-raw-svg [name frame-id svg-data {:keys [attrs] :as data}]
(let [{:keys [x y width height offset-x offset-y]} svg-data]
(-> {:id (uuid/next)
:type :svg-raw
:name name
:frame-id frame-id
:width width
:height height
:x x
:y y
:content (cond-> data
(map? data) (update :attrs usvg/clean-attrs))}
(assoc :svg-attrs attrs)
(assoc :svg-viewbox (-> (select-keys svg-data [:width :height])
(assoc :x offset-x :y offset-y)))
(cts/setup-rect-selrect))))
(defn create-raw-svg
[name frame-id {:keys [x y width height offset-x offset-y]} {:keys [attrs] :as data}]
(cts/setup-shape
{:type :svg-raw
:name name
:frame-id frame-id
:width width
:height height
:x x
:y y
:content (cond-> data
(map? data) (update :attrs usvg/clean-attrs))
:svg-attrs attrs
:svg-viewbox {:width width
:height height
:x offset-x
:y offset-y}}))
(defn create-svg-root [frame-id parent-id svg-data]
(let [{:keys [name x y width height offset-x offset-y]} svg-data]
(-> {:id (uuid/next)
:type :group
:name name
:frame-id frame-id
:parent-id parent-id
:width width
:height height
:x (+ x offset-x)
:y (+ y offset-y)}
(cts/setup-rect-selrect)
(assoc :svg-attrs (-> (:attrs svg-data)
(dissoc :viewBox :xmlns)
(d/without-keys usvg/inheritable-props))))))
(defn create-svg-root
[frame-id parent-id {:keys [name x y width height offset-x offset-y attrs]}]
(cts/setup-shape
{:type :group
:name name
:frame-id frame-id
:parent-id parent-id
:width width
:height height
:x (+ x offset-x)
:y (+ y offset-y)
:svg-attrs (-> attrs
(dissoc :viewBox)
(dissoc :xmlns)
(d/without-keys usvg/inheritable-props))}))
(defn create-group [name frame-id svg-data {:keys [attrs]}]
(let [svg-transform (usvg/parse-transform (:transform attrs))
{:keys [x y width height offset-x offset-y]} svg-data]
(-> {:id (uuid/next)
:type :group
:name name
:frame-id frame-id
:x (+ x offset-x)
:y (+ y offset-y)
:width width
:height height}
(assoc :svg-transform svg-transform)
(assoc :svg-attrs (d/without-keys attrs usvg/inheritable-props))
(assoc :svg-viewbox (-> (select-keys svg-data [:width :height])
(assoc :x offset-x :y offset-y)))
(cts/setup-rect-selrect))))
(defn create-group
[name frame-id {:keys [x y width height offset-x offset-y] :as svg-data} {:keys [attrs]}]
(let [svg-transform (usvg/parse-transform (:transform attrs))]
(cts/setup-shape
{:type :group
:name name
:frame-id frame-id
:x (+ x offset-x)
:y (+ y offset-y)
:width width
:height height
:svg-transform svg-transform
:svg-attrs (d/without-keys attrs usvg/inheritable-props)
:svg-viewbox {:width width
:height height
:x offset-x
:y offset-y}})))
(defn create-path-shape [name frame-id svg-data {:keys [attrs] :as data}]
(when (and (contains? attrs :d) (seq (:d attrs)))
(let [svg-transform (usvg/parse-transform (:transform attrs))
path-content (upp/parse-path (:d attrs))
content (cond-> path-content
svg-transform
(gsh/transform-content svg-transform))
path-content (upp/parse-path (:d attrs))
content (cond-> path-content
svg-transform
(gsh/transform-content svg-transform))
selrect (gsh/content->selrect content)
points (gsh/rect->points selrect)
selrect (gsh/content->selrect content)
points (grc/rect->points selrect)
origin (gpt/negate (gpt/point svg-data))]
(-> {:id (uuid/next)
:type :path
:name name
:frame-id frame-id
:content content
:selrect selrect
:points points}
(assoc :svg-viewbox (select-keys selrect [:x :y :width :height]))
(assoc :svg-attrs (dissoc attrs :d :transform))
(assoc :svg-transform svg-transform)
origin (gpt/negate (gpt/point svg-data))]
(-> (cts/setup-shape
{:type :path
:name name
:frame-id frame-id
:content content
:selrect selrect
:points points
:svg-viewbox (select-keys selrect [:x :y :width :height])
:svg-attrs (dissoc attrs :d :transform)
:svg-transform svg-transform})
(gsh/translate-to-frame origin)))))
(defn calculate-rect-metadata [rect-data transform]
(let [points (-> (gsh/rect->points rect-data)
(let [points (-> (grc/make-rect rect-data)
(grc/rect->points)
(gsh/transform-points transform))
[selrect transform transform-inverse] (gsh/calculate-geometry points)]
@ -285,122 +283,113 @@
:transform transform
:transform-inverse transform-inverse}))
(defn- parse-rect-attrs
[{:keys [x y width height]}]
{:x (d/parse-double x 0)
:y (d/parse-double y 0)
:width (d/parse-double width 1)
:height (d/parse-double height 1)})
(defn create-rect-shape [name frame-id svg-data {:keys [attrs] :as data}]
(let [svg-transform (usvg/parse-transform (:transform attrs))
transform (->> svg-transform
(let [transform (->> (usvg/parse-transform (:transform attrs))
(gmt/transform-in (gpt/point svg-data)))
rect (->> (select-keys attrs [:x :y :width :height])
(d/mapm #(d/parse-double %2)))
origin (gpt/negate (gpt/point svg-data))
origin (gpt/negate (gpt/point svg-data))
rect-data (-> (merge default-rect rect)
rect-data (-> (parse-rect-attrs attrs)
(update :x - (:x origin))
(update :y - (:y origin)))
(update :y - (:y origin)))]
metadata (calculate-rect-metadata rect-data transform)]
(-> {:id (uuid/next)
:type :rect
:name name
:frame-id frame-id}
(cond->
(contains? attrs :rx) (assoc :rx (d/parse-double (:rx attrs 0)))
(contains? attrs :ry) (assoc :ry (d/parse-double (:ry attrs 0))))
(cts/setup-shape
(-> (calculate-rect-metadata rect-data transform)
(assoc :type :rect)
(assoc :name name)
(assoc :frame-id frame-id)
(assoc :svg-viewbox (select-keys rect-data [:x :y :width :height]))
(assoc :svg-attrs (dissoc attrs :x :y :width :height :rx :ry :transform))
(cond-> (contains? attrs :rx)
(assoc :rx (d/parse-double (:rx attrs) 0)))
(cond-> (contains? attrs :ry)
(assoc :ry (d/parse-double (:ry attrs) 0)))))))
(merge metadata)
(assoc :svg-viewbox (select-keys rect [:x :y :width :height]))
(assoc :svg-attrs (dissoc attrs :x :y :width :height :rx :ry :transform)))))
(defn- parse-circle-attrs
[attrs]
(into [] (comp (map (d/getf attrs))
(map d/parse-double))
[:cx :cy :r :rx :ry]))
(defn create-circle-shape [name frame-id svg-data {:keys [attrs] :as data}]
(let [svg-transform (usvg/parse-transform (:transform attrs))
transform (->> svg-transform
(let [[cx cy r rx ry]
(parse-circle-attrs attrs)
transform (->> (usvg/parse-transform (:transform attrs))
(gmt/transform-in (gpt/point svg-data)))
circle (->> (select-keys attrs [:r :ry :rx :cx :cy])
(d/mapm #(d/parse-double %2)))
rx (or r rx)
ry (or r ry)
origin (gpt/negate (gpt/point svg-data))
{:keys [cx cy]} circle
rect-data {:x (- cx rx (:x origin))
:y (- cy ry (:y origin))
:width (* 2 rx)
:height (* 2 ry)}]
rx (or (:r circle) (:rx circle))
ry (or (:r circle) (:ry circle))
rect {:x (- cx rx)
:y (- cy ry)
:width (* 2 rx)
:height (* 2 ry)}
origin (gpt/negate (gpt/point svg-data))
rect-data (-> rect
(update :x - (:x origin))
(update :y - (:y origin)))
metadata (calculate-rect-metadata rect-data transform)]
(-> {:id (uuid/next)
:type :circle
:name name
:frame-id frame-id}
(merge metadata)
(assoc :svg-viewbox (select-keys rect [:x :y :width :height]))
(assoc :svg-attrs (dissoc attrs :cx :cy :r :rx :ry :transform)))))
(cts/setup-shape
(-> (calculate-rect-metadata rect-data transform)
(assoc :type :circle)
(assoc :name name)
(assoc :frame-id frame-id)
(assoc :svg-viewbox rect-data)
(assoc :svg-attrs (dissoc attrs :cx :cy :r :rx :ry :transform))))))
(defn create-image-shape [name frame-id svg-data {:keys [attrs] :as data}]
(let [svg-transform (usvg/parse-transform (:transform attrs))
transform (->> svg-transform
(gmt/transform-in (gpt/point svg-data)))
(let [transform (->> (usvg/parse-transform (:transform attrs))
(gmt/transform-in (gpt/point svg-data)))
image-url (or (:href attrs) (:xlink:href attrs))
image-data (get-in svg-data [:image-data image-url])
image-url (or (:href attrs) (:xlink:href attrs))
image-data (dm/get-in svg-data [:image-data image-url])
rect (->> (select-keys attrs [:x :y :width :height])
(d/mapm #(d/parse-double %2)))
origin (gpt/negate (gpt/point svg-data))
metadata {:width (:width image-data)
:height (:height image-data)
:mtype (:mtype image-data)
:id (:id image-data)}
rect-data (-> (merge default-image rect)
(update :x - (:x origin))
(update :y - (:y origin)))
rect-metadata (calculate-rect-metadata rect-data transform)]
origin (gpt/negate (gpt/point svg-data))
rect-data (-> (parse-rect-attrs attrs)
(update :x - (:x origin))
(update :y - (:y origin)))]
(when (some? image-data)
(-> {:id (uuid/next)
:type :image
:name name
:frame-id frame-id
:metadata {:width (:width image-data)
:height (:height image-data)
:mtype (:mtype image-data)
:id (:id image-data)}}
(cts/setup-shape
(-> (calculate-rect-metadata rect-data transform)
(assoc :type :image)
(assoc :name name)
(assoc :frame-id frame-id)
(assoc :metadata metadata)
(assoc :svg-viewbox (select-keys rect-data [:x :y :width :height]))
(assoc :svg-attrs (dissoc attrs :x :y :width :height :href :xlink:href)))))))
(merge rect-metadata)
(assoc :svg-viewbox (select-keys rect [:x :y :width :height]))
(assoc :svg-attrs (dissoc attrs :x :y :width :height :href :xlink:href))))))
(defn parse-svg-element [frame-id svg-data element-data unames]
(let [{:keys [tag attrs hidden]} element-data
attrs (usvg/format-styles attrs)
(defn parse-svg-element [frame-id svg-data {:keys [tag attrs hidden] :as element-data} unames]
(let [attrs (usvg/format-styles attrs)
element-data (cond-> element-data (map? element-data) (assoc :attrs attrs))
name (or (:id attrs) (tag->name tag))
att-refs (usvg/find-attr-references attrs)
references (usvg/find-def-references (:defs svg-data) att-refs)
name (or (:id attrs) (tag->name tag))
att-refs (usvg/find-attr-references attrs)
references (usvg/find-def-references (:defs svg-data) att-refs)
href-id (-> (or (:href attrs) (:xlink:href attrs) "")
(subs 1))
defs (:defs svg-data)
href-id (-> (or (:href attrs) (:xlink:href attrs) "") (subs 1))
defs (:defs svg-data)
use-tag? (and (= :use tag) (contains? defs href-id))]
use-tag? (and (= :use tag) (contains? defs href-id))]
(if use-tag?
(let [;; Merge the data of the use definition with the properties passed as attributes
use-data (-> (get defs href-id)
(update :attrs #(d/deep-merge % (dissoc attrs :xlink:href :href))))
use-data (-> (get defs href-id)
(update :attrs #(d/deep-merge % (dissoc attrs :xlink:href :href))))
displacement (gpt/point (d/parse-double (:x attrs "0")) (d/parse-double (:y attrs "0")))
disp-matrix (str (gmt/translate-matrix displacement))
disp-matrix (str (gmt/translate-matrix displacement))
element-data (-> element-data
(assoc :tag :g)
(update :attrs dissoc :x :y :width :height :href :xlink:href :transform)
@ -423,37 +412,32 @@
#_other (create-raw-svg name frame-id svg-data element-data)))]
(when (some? shape)
(let [shape (-> shape
(assoc :fills [])
(assoc :strokes [])
(assoc :svg-defs (select-keys (:defs svg-data) references))
(setup-fill)
(setup-stroke)
(setup-opacity))
(setup-opacity))]
shape (cond-> shape
hidden (assoc :hidden true))
[(cond-> shape
hidden (assoc :hidden true))
children (cond->> (:content element-data)
(contains? usvg/parent-tags tag)
(mapv #(usvg/inherit-attributes attrs %)))]
[shape children]))))))
(cond->> (:content element-data)
(contains? usvg/parent-tags tag)
(mapv #(usvg/inherit-attributes attrs %)))]))))))
(defn create-svg-children
[objects selected frame-id parent-id svg-data [unames children] [_index svg-element]]
(let [[new-shape new-children] (parse-svg-element frame-id svg-data svg-element unames)]
(if (some? new-shape)
(let [shape-id (:id new-shape)
(let [[shape new-children] (parse-svg-element frame-id svg-data svg-element unames)]
(if (some? shape)
(let [shape-id (:id shape)
shape (-> shape
(assoc :frame-id frame-id)
(assoc :parent-id parent-id))
children (conj children shape)
unames (conj unames (:name shape))]
new-shape' (-> (dwsh/make-new-shape new-shape objects selected)
(assoc :parent-id parent-id))
children (conj children new-shape')
unames (conj unames (:name new-shape'))
reducer-fn (partial create-svg-children objects selected frame-id shape-id svg-data)]
(reduce reducer-fn [unames children] (d/enumerate new-children)))
(reduce (partial create-svg-children objects selected frame-id shape-id svg-data)
[unames children]
(d/enumerate new-children)))
[unames children])))
@ -502,111 +486,111 @@
(rx/map #(vector (:url uri-data) %)))))
(rx/reduce (fn [acc [url image]] (assoc acc url image)) {})))
(defn create-svg-shapes
[svg-data {:keys [x y]} objects frame-id parent-id selected center?]
(let [[vb-x vb-y vb-width vb-height] (svg-dimensions svg-data)
x (mth/round
(if center?
(- x vb-x (/ vb-width 2))
x))
y (mth/round
(if center?
(- y vb-y (/ vb-height 2))
y))
unames (cp/retrieve-used-names objects)
unames (cfh/get-used-names objects)
svg-name (str/replace (:name svg-data) ".svg" "")
svg-data (-> svg-data
(assoc :x x
:y y
:offset-x vb-x
:offset-y vb-y
:width vb-width
:height vb-height
:name svg-name))
(assoc :x (mth/round
(if center?
(- x vb-x (/ vb-width 2))
x)))
(assoc :y (mth/round
(if center?
(- y vb-y (/ vb-height 2))
y)))
(assoc :offset-x vb-x)
(assoc :offset-y vb-y)
(assoc :width vb-width)
(assoc :height vb-height)
(assoc :name svg-name))
[def-nodes svg-data] (-> svg-data
(usvg/fix-default-values)
(usvg/fix-percents)
(usvg/extract-defs))
svg-data (assoc svg-data :defs def-nodes)
[def-nodes svg-data]
(-> svg-data
(usvg/fix-default-values)
(usvg/fix-percents)
(usvg/extract-defs))
svg-data (assoc svg-data :defs def-nodes)
root-shape (create-svg-root frame-id parent-id svg-data)
root-id (:id root-shape)
root-id (:id root-shape)
;; In penpot groups have the size of their children. To respect the imported
;; svg size and empty space let's create a transparent shape as background to respect the imported size
base-background-shape {:tag :rect
:attrs {:x (str vb-x)
:y (str vb-y)
:width (str vb-width)
:height (str vb-height)
:fill "none"
:id "base-background"}
:hidden true
:content []}
;; In penpot groups have the size of their children. To
;; respect the imported svg size and empty space let's create
;; a transparent shape as background to respect the imported
;; size
background
{:tag :rect
:attrs {:x (dm/str vb-x)
:y (dm/str vb-y)
:width (dm/str vb-width)
:height (dm/str vb-height)
:fill "none"
:id "base-background"}
:hidden true
:content []}
svg-data (-> svg-data
(assoc :defs def-nodes)
(assoc :content (into [base-background-shape] (:content svg-data))))
svg-data (-> svg-data
(assoc :defs def-nodes)
(assoc :content (into [background] (:content svg-data))))
;; Create the root shape
new-shape (dwsh/make-new-shape root-shape objects selected)
root-attrs (-> (:attrs svg-data)
(usvg/format-styles))
[_ new-children]
[_ children]
(reduce (partial create-svg-children objects selected frame-id root-id svg-data)
[unames []]
(d/enumerate (->> (:content svg-data)
(mapv #(usvg/inherit-attributes root-attrs %)))))]
[new-shape new-children]))
[root-shape children]))
(defn add-svg-shapes
[svg-data position]
;; (app.common.pprint/pprint svg-data {:length 100 :level 100})
(ptk/reify ::add-svg-shapes
ptk/WatchEvent
(watch [it state _]
(try
(let [page-id (:current-page-id state)
objects (wsh/lookup-page-objects state page-id)
frame-id (ctst/top-nested-frame objects position)
selected (wsh/lookup-selected state)
page-objects (wsh/lookup-page-objects state)
base (cph/get-base-shape page-objects selected)
selected-frame? (and (= 1 (count selected))
(= :frame (get-in objects [(first selected) :type])))
(let [page-id (:current-page-id state)
objects (wsh/lookup-page-objects state page-id)
frame-id (ctst/top-nested-frame objects position)
selected (wsh/lookup-selected state)
base (cph/get-base-shape objects selected)
parent-id
(if (or selected-frame? (empty? selected))
frame-id
(:parent-id base))
selected-id (first selected)
selected-frame? (and (= 1 (count selected))
(= :frame (dm/get-in objects [selected-id :type])))
parent-id (if (or selected-frame? (empty? selected))
frame-id
(:parent-id base))
[new-shape new-children]
(create-svg-shapes svg-data position objects frame-id parent-id selected true)
changes (-> (pcb/empty-changes it page-id)
(pcb/with-objects objects)
(pcb/add-object new-shape))
changes (-> (pcb/empty-changes it page-id)
(pcb/with-objects objects)
(pcb/add-object new-shape))
changes
(reduce (fn [changes new-child]
(-> changes (pcb/add-object new-child)))
changes new-children)
changes (reduce (fn [changes new-child]
(pcb/add-object changes new-child))
changes
new-children)
changes (pcb/resize-parents changes
(->> changes
:redo-changes
(filter #(= :add-obj (:type %)))
(map :id)
reverse
vec))
undo-id (js/Symbol)]
changes (pcb/resize-parents changes
(->> (:redo-changes changes)
(filter #(= :add-obj (:type %)))
(map :id)
(reverse)
(vec)))
undo-id (js/Symbol)]
(rx/of (dwu/start-undo-transaction undo-id)
(dch/commit-changes changes)
@ -614,7 +598,7 @@
(ptk/data-event :layout/update [(:id new-shape)])
(dwu/commit-undo-transaction undo-id)))
(catch :default e
(.error js/console "Error SVG" e)
(catch :default cause
(js/console.log (.-stack cause))
(rx/throw {:type :svg-parser
:data e}))))))
:data cause}))))))

18
frontend/src/app/main/data/workspace/transforms.cljs
View File

@ -11,6 +11,7 @@
[app.common.data.macros :as dm]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as grc]
[app.common.geom.shapes :as gsh]
[app.common.geom.shapes.flex-layout :as gslf]
[app.common.geom.shapes.grid-layout :as gslg]
@ -109,7 +110,7 @@
(let [{:keys [width height]} (:selrect shape)
{:keys [rotation]} shape
shape-center (gsh/center-shape shape)
shape-center (gsh/shape->center shape)
shape-transform (:transform shape)
shape-transform-inverse (:transform-inverse shape)
@ -304,8 +305,8 @@
ptk/WatchEvent
(watch [_ _ stream]
(let [stoper (rx/filter ms/mouse-up? stream)
group (gsh/selection-rect shapes)
group-center (gsh/center-selrect group)
group (gsh/shapes->rect shapes)
group-center (grc/rect->center group)
initial-angle (gpt/angle @ms/mouse-position group-center)
calculate-angle
@ -717,7 +718,8 @@
objects (wsh/lookup-page-objects state page-id)
shape (get objects id)
bbox (-> shape :points gsh/points->selrect)
;; FIXME: performance rect
bbox (-> shape :points grc/points->rect)
cpos (gpt/point (:x bbox) (:y bbox))
pos (gpt/point (or (:x position) (:x bbox))
@ -840,8 +842,8 @@
(let [objects (wsh/lookup-page-objects state)
selected (wsh/lookup-selected state {:omit-blocked? true})
shapes (map #(get objects %) selected)
selrect (gsh/selection-rect shapes)
center (gsh/center-selrect selrect)
selrect (gsh/shapes->rect shapes)
center (grc/rect->center selrect)
modifiers (dwm/create-modif-tree selected (ctm/resize-modifiers (gpt/point -1.0 1.0) center))]
(rx/of (dwm/apply-modifiers {:modifiers modifiers}))))))
@ -852,7 +854,7 @@
(let [objects (wsh/lookup-page-objects state)
selected (wsh/lookup-selected state {:omit-blocked? true})
shapes (map #(get objects %) selected)
selrect (gsh/selection-rect shapes)
center (gsh/center-selrect selrect)
selrect (gsh/shapes->rect shapes)
center (grc/rect->center selrect)
modifiers (dwm/create-modif-tree selected (ctm/resize-modifiers (gpt/point 1.0 -1.0) center))]
(rx/of (dwm/apply-modifiers {:modifiers modifiers}))))))

26
frontend/src/app/main/data/workspace/viewport.cljs
View File

@ -10,6 +10,7 @@
[app.common.data.macros :as dm]
[app.common.geom.align :as gal]
[app.common.geom.point :as gpt]
[app.common.geom.rect :as gpr]
[app.common.geom.shapes :as gsh]
[app.common.math :as mth]
[app.common.pages.helpers :as cph]
@ -21,6 +22,10 @@
(defn initialize-viewport
[{:keys [width height] :as size}]
(dm/assert!
"expected `size` to be a rect instance"
(gpr/rect? size))
(letfn [(update* [{:keys [vport] :as local}]
(let [wprop (/ (:width vport) width)
hprop (/ (:height vport) height)]
@ -29,13 +34,14 @@
(update :vbox (fn [vbox]
(-> vbox
(update :width #(/ % wprop))
(update :height #(/ % hprop))))))))
(update :height #(/ % hprop))
(gpr/update-rect :size)))))))
(initialize [state local]
(let [page-id (:current-page-id state)
objects (wsh/lookup-page-objects state page-id)
shapes (cph/get-immediate-children objects)
srect (gsh/selection-rect shapes)
srect (gsh/shapes->rect shapes)
local (assoc local :vport size :zoom 1 :zoom-inverse 1)]
(cond
(or (not (d/num? (:width srect)))
@ -49,12 +55,20 @@
(-> local
(assoc :zoom zoom)
(assoc :zoom-inverse (/ 1 zoom))
(update :vbox merge srect)))
(update :vbox (fn [vbox]
(-> (merge vbox srect)
(gpr/make-rect))))))
:else
(assoc local :vbox (assoc size
:x (+ (:x srect) (/ (- (:width srect) width) 2))
:y (+ (:y srect) (/ (- (:height srect) height) 2)))))))
(let [vx (+ (:x srect)
(/ (- (:width srect) width) 2))
vy (+ (:y srect)
(/ (- (:height srect) height) 2))
vbox (-> size
(assoc :x vx)
(assoc :y vy)
(gpr/update-rect :position))]
(assoc local :vbox vbox)))))
(setup [state local]
(if (and (:vbox local) (:vport local))

Some files were not shown because too many files have changed in this diff Show More