0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-03-15 17:21:17 -05:00

Add new geom impl under uxbox.util.geom ns.

This commit is contained in:
Andrey Antukh 2016-04-20 20:35:02 +03:00
parent 1c13b62f25
commit 8b5b1697b2
No known key found for this signature in database
GPG key ID: 4DFEBCB8316A8B95

564
src/uxbox/util/geom.cljs Normal file
View file

@ -0,0 +1,564 @@
;; 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) 2016 Andrey Antukh <niwi@niwi.nz>
(ns uxbox.util.geom
(:require [uxbox.util.geom.matrix :as gmt]
[uxbox.util.geom.point :as gpt]
[uxbox.util.math :as mth]
[uxbox.state :as st]))
;; --- Types
(def ^:const +hierarchy+
(-> (make-hierarchy)
(derive ::rect ::shape)
(derive :icon ::rect)
(derive :rect ::rect)
(derive :line ::shape)
(derive :circle ::shape)
(derive :text ::rect)
(derive :group ::rect)))
(defn shape?
[type]
(isa? +hierarchy+ type ::shape))
;; --- Relative Movement
(declare move-rect)
(declare move-circle)
(declare move-group)
(defn move
"Move the shape relativelly to its current
position applying the provided delta."
[shape dpoint]
(case (:type shape)
:icon (move-rect shape dpoint)
:rect (move-rect shape dpoint)
:line (move-rect shape dpoint)
:circle (move-circle shape dpoint)
:group (move-group shape dpoint)))
(defn- move-rect
"A specialized function for relative movement
for rect-like shapes."
[shape {dx :x dy :y}]
(assoc shape
:x1 (+ (:x1 shape) dx)
:y1 (+ (:y1 shape) dy)
:x2 (+ (:x2 shape) dx)
:y2 (+ (:y2 shape) dy)))
(defn- move-circle
"A specialized function for relative movement
for circle shapes."
[shape {dx :x dy :y}]
(assoc shape
:cx (+ (:cx shape) dx)
:cy (+ (:cy shape) dy)))
(defn- move-group
"A specialized function for relative movement
for group shapes."
[shape {dx :x dy :y}]
(assoc shape
:dx (+ (:dx shape 0) dx)
:dy (+ (:dy shape 0) dy)))
;; --- Absolute Movement
(declare absolute-move-rect)
(declare absolute-move-circle)
(declare absolute-move-group)
(defn absolute-move
"Move the shape to the exactly specified position."
[shape point]
(case (:type shape)
:icon (absolute-move-rect shape point)
:rect (absolute-move-rect shape point)
:line (absolute-move-rect shape point)
:circle (absolute-move-circle shape point)
:group (absolute-move-group shape point)))
(defn- absolute-move-rect
"A specialized function for absolute moviment
for rect-like shapes."
[shape {:keys [x y] :as pos}]
(let [dx (if x (- (:x1 shape) x) 0)
dy (if y (- (:y1 shape) y) 0)]
(move shape (gpt/point dx dy))))
(defn- absolute-move-circle
"A specialized function for absolute moviment
for rect-like shapes."
[shape {:keys [x y] :as pos}]
(let [dx (if x (- (:cx shape) x) 0)
dy (if y (- (:cy shape) y) 0)]
(move shape (gpt/point dx dy))))
(defn- absolute-move-group
"A specialized function for absolute moviment
for rect-like shapes."
[shape {:keys [x y] :as pos}]
(throw (ex-info "Not implemented (TODO)" {})))
;; --- Rotation
;; TODO: maybe we can consider apply the rotation
;; directly to the shape coordinates?
(defn rotate
"Apply the rotation to the shape."
[shape rotation]
(assoc shape :rotation rotation))
;; --- Size
(declare rect-size)
(defn size
"Calculate the size of the shape."
[shape]
(case (:type shape)
:rect (rect-size shape)
:icon (rect-size shape)
:line (rect-size shape)))
(defn- rect-size
"A specialized function for calculate size
for rect-like shapes."
[{:keys [x1 y1 x2 y2] :as shape}]
{:width (- x2 x1)
:height (- y2 y1)})
;; --- Vertex Movement (Relative)
(declare move-rect-vertex)
(declare move-circle-vertex)
(defn move-vertex
"Resize the shape moving one of its vertex using
relative delta."
[shape vid dpoint]
(case (:type shape)
:rect (move-rect-vertex shape vid dpoint)
:icon (move-rect-vertex shape vid dpoint)
:circle (move-circle-vertex shape vid dpoint)))
(defn- move-rect-vertex
"A specialized function for vertex movement
for rect-like shapes."
[shape vid {dx :x dy :y}]
(let [{:keys [x1 x2 y1 y2]} shape]
(case vid
1 (assoc shape
:x1 (min x2 (+ x1 dx))
:y1 (min y2 (+ y1 dy)))
2 (assoc shape
:x2 (max x1 (+ x2 dx))
:y1 (min y2 (+ y1 dy)))
3 (assoc shape
:x1 (min x2 (+ x1 dx))
:y2 (max y1 (+ y2 dy)))
4 (assoc shape
:x2 (max x1 (+ x2 dx))
:y2 (max y1 (+ y2 dy))))))
(defn- move-circle-vertex
"A specialized function for vertex movement
for circle shapes."
[shape vid {dx :x dy :y lock :lock}]
(let [[dx dy] (if lock [dx dx] [dx dy])]
(case vid
1 (assoc shape
:rx (- (:rx shape) dx)
:ry (- (:ry shape) dy))
2 (assoc shape
:rx (+ (:rx shape) dx)
:ry (- (:ry shape) dy))
3 (assoc shape
:rx (- (:rx shape) dx)
:ry (+ (:ry shape) dy))
4 (assoc shape
:rx (+ (:rx shape) dx)
:ry (+ (:ry shape) dy)))))
;; --- Resize (Absolute)
(declare resize-rect)
(declare resize-line)
(declare resize-circle)
(declare normalize-shape)
(declare equalize-sides)
(defn resize
"Resize the shape using absolute position.
NOTE: used in draw operation."
[shape point]
(case (:type shape)
:rect (resize-rect shape point)
:icon (resize-rect shape point)
:text (resize-rect shape point)
:line (resize-line shape point)
:circle (resize-circle shape point)))
(defn- resize-rect
"A specialized function for absolute resize
for rect-like shapes."
[shape {:keys [x y lock] :as pos}]
(if lock
(-> (assoc shape :x2 x :y2 y)
(equalize-sides)
(normalize-shape))
(normalize-shape (assoc shape :x2 x :y2 y))))
(defn- resize-circle
"A specialized function for absolute resize
for circle shapes."
[shape {:keys [x y lock] :as pos}]
(let [cx (:cx shape)
cy (:cy shape)
rx (mth/abs (- x cx))
ry (mth/abs (- y cy))]
(if lock
(assoc shape :rx rx :ry rx)
(assoc shape :rx rx :ry ry))))
(defn- resize-line
"A specialized function for absolute resize
for line shapes."
[shape {:keys [x y] :as pos}]
(assoc shape :x2 x :y2 y))
(defn- normalize-shape
"Normalize shape coordinates."
[shape]
(let [x1 (min (:x1 shape) (:x2 shape))
y1 (min (:y1 shape) (:y2 shape))
x2 (max (:x1 shape) (:x2 shape))
y2 (max (:y1 shape) (:y2 shape))]
(assoc shape :x1 x1 :x2 x2 :y1 y1 :y2 y2)))
(defn- equalize-sides
"Fix shape sides to be equal according to the lock mode."
[shape]
(let [{:keys [x1 x2 y1 y2]} shape
x-side (mth/abs (- x2 x1))
y-side (mth/abs (- y2 y1))
max-side (max x-side y-side)]
(cond
(and (> x1 x2) (> y1 y2))
(assoc shape :x2 (- x1 max-side) :y2 (- y1 max-side))
(and (< x1 x2) (< y1 y2))
(assoc shape :x2 (+ x1 max-side) :y2 (+ y1 max-side))
(and (> x1 x2) (< y1 y2))
(assoc shape :x2 (- x1 max-side) :y2 (+ y1 max-side))
(and (< x1 x2) (> y1 y2))
(assoc shape :x2 (+ x1 max-side) :y2 (- y1 max-side)))))
;; --- Setup (Initialize)
(declare setup-rect)
(declare setup-circle)
(declare setup-group)
(defn setup
"A function that initializes the first coordinates for
the shape. Used mainly for draw operations."
[shape props]
(case (:type shape)
:rect (setup-rect shape props)
:icon (setup-rect shape props)
:line (setup-rect shape props)
:text (setup-rect shape props)
:circle (setup-circle shape props)
:group (setup-group shape props)))
(defn- setup-rect
"A specialized function for setup rect-like shapes."
[shape {:keys [x1 y1 x2 y2]}]
(assoc shape
:x1 x1
:y1 y1
:x2 x2
:y2 y2))
(defn- setup-group
"A specialized function for setup group shapes."
[shape {:keys [x1 y1 x2 y2] :as props}]
(assoc shape :initial props))
(defn- setup-circle
"A specialized function for setup circle shapes."
[shape {:keys [x1 y1 x2 y2]}]
(assoc shape
:cx x1
:cy y1
:rx (mth/abs (- x2 x1))
:ry (mth/abs (- y2 y1))))
;; --- Outer Rect
(declare generic-outer-rect)
(declare line-outer-rect)
(declare circle-outer-rect)
(declare group-outer-rect)
(declare apply-rotation-transformation)
(defn outer-rect
([shape]
(outer-rect @st/state shape))
([state shape]
(case (:type shape)
:rect (generic-outer-rect state shape)
:text (generic-outer-rect state shape)
:icon (generic-outer-rect state shape)
:line (line-outer-rect state shape)
:circle (circle-outer-rect state shape)
:group (group-outer-rect state shape))))
(defn outer-rect-coll
[shapes]
{:pre [(seq shapes)]}
(let [shapes (map outer-rect shapes)
x (apply min (map :x shapes))
y (apply min (map :y shapes))
x' (apply max (map (fn [{:keys [x width]}] (+ x width)) shapes))
y' (apply max (map (fn [{:keys [y height]}] (+ y height)) shapes))
width (- x' x)
height (- y' y)]
{:width width
:height height
:x x
:y y}))
(defn- generic-outer-rect
[state {:keys [x1 y1] :as shape}]
(-> (assoc shape :x x1 :y y1)
(merge (size shape))
(apply-rotation-transformation)))
(defn- line-outer-rect
[state {:keys [x1 y1 x2 y2 group] :as shape}]
(let [group (get-in state [:shapes-by-id group])
props {:x (+ x1 (:dx group 0))
:y (+ y1 (:dy group 0))
:width (- x2 x1)
:height (- y2 y1)}]
(-> (merge shape props)
(apply-rotation-transformation))))
(defn- circle-outer-rect
[state {:keys [cx cy rx ry group] :as shape}]
(let [group (get-in state [:shapes-by-id group])
props {:x (+ (- cx rx) (:dx group 0))
:y (+ (- cy ry) (:dy group 0))
:width (* rx 2)
:height (* ry 2)}]
(-> (merge shape props)
(apply-rotation-transformation))))
(defn- group-outer-rect
[state {:keys [id group rotation dx dy] :as shape}]
(let [shapes (->> (:items shape)
(map #(get-in @st/state [:shapes-by-id %]))
(map (partial outer-rect state)))
x (apply min (map :x shapes))
y (apply min (map :y shapes))
x' (apply max (map (fn [{:keys [x width]}] (+ x width)) shapes))
y' (apply max (map (fn [{:keys [y height]}] (+ y height)) shapes))
width (- x' x)
height (- y' y)
x (+ x dx)
y (+ y dy)]
(-> (merge shape {:width width :height height :x x :y y})
(apply-rotation-transformation))))
(declare apply-rotation)
(defn- apply-rotation-transformation
[{:keys [x y width height rotation] :as shape}]
(let [center-x (+ x (/ width 2))
center-y (+ y (/ height 2))
angle (mth/radians (or rotation 0))
x1 (- x center-x)
y1 (- y center-y)
x2 (- (+ x width) center-x)
y2 (- y center-y)
[rx1 ry1] (apply-rotation [x1 y1] rotation)
[rx2 ry2] (apply-rotation [x2 y2] rotation)
[d1 d2] (cond
(and (>= rotation 0)
(< rotation 90))
[(mth/abs ry1)
(mth/abs rx2)]
(and (>= rotation 90)
(< rotation 180))
[(mth/abs ry2)
(mth/abs rx1)]
(and (>= rotation 180)
(< rotation 270))
[(mth/abs ry1)
(mth/abs rx2)]
(and (>= rotation 270)
(<= rotation 360))
[(mth/abs ry2)
(mth/abs rx1)])
final-x (- center-x d2)
final-y (- center-y d1)
final-width (* d2 2)
final-height (* d1 2)]
(merge shape
{:x final-x
:y final-y
:width final-width
:height final-height})))
;; --- Transformation Matrix
(declare rect-transformation-matrix)
(declare text-transformation-matrix)
(declare circle-transformation-matrix)
(declare icon-transformation-matrix)
(declare group-transformation-matrix)
(defn transformation-matrix
([shape]
(transformation-matrix @st/state shape))
([state shape]
(case (:type shape)
:rect (rect-transformation-matrix state shape)
:text (text-transformation-matrix state shape)
:circle (circle-transformation-matrix state shape)
:icon (icon-transformation-matrix state shape)
:group (group-transformation-matrix state shape))))
(defn- rect-transformation-matrix
[state {:keys [x1 y1 rotation] :or {rotation 0} :as shape}]
(let [{:keys [width height]} (size shape)
center-x (+ x1 (/ width 2))
center-y (+ y1 (/ height 2))]
(-> (gmt/matrix)
(gmt/translate center-x center-y)
(gmt/rotate rotation)
(gmt/translate (- center-x) (- center-y)))))
(defn- text-transformation-matrix
[state {:keys [x1 y1 rotation] :or {rotation 0} :as shape}]
(let [{:keys [width height]} (size shape)
center-x (+ x1 (/ width 2))
center-y (+ y1 (/ height 2))]
(-> (gmt/matrix)
(gmt/translate center-x center-y)
(gmt/rotate rotation)
(gmt/translate (- center-x) (- center-y)))))
(defn- icon-transformation-matrix
[state {:keys [x1 y1 rotation view-box] :or {rotation 0} :as shape}]
(let [{:keys [width height]} (size shape)
orig-width (nth view-box 2)
orig-height (nth view-box 3)
scale-x (/ width orig-width)
scale-y (/ height orig-height)
center-x (- width (/ width 2))
center-y (- height (/ height 2))]
(-> (gmt/matrix)
(gmt/translate x1 y1)
(gmt/translate center-x center-y)
(gmt/rotate rotation)
(gmt/translate (- center-x) (- center-y))
(gmt/scale scale-x scale-y))))
(defn- circle-transformation-matrix
[state {:keys [cx cy rx ry rotation] :or {rotation 0} :as shape}]
(-> (gmt/matrix)
(gmt/translate cx cy)
(gmt/rotate rotation)
(gmt/translate (- cx) (- cy))))
;; --- Helpers
(defn apply-rotation
[[x y :as v] rotation]
(let [angle (mth/radians rotation)
rx (- (* x (mth/cos angle))
(* y (mth/sin angle)))
ry (+ (* x (mth/sin angle))
(* y (mth/cos angle)))]
(let [r [(mth/precision rx 6)
(mth/precision ry 6)]]
r)))
(defn resolve-parent
"Recursively resolve the real shape parent."
([shape]
(resolve-parent @st/state shape))
([state {:keys [group] :as shape}]
(if group
(resolve-parent state (get-in state [:shapes-by-id group]))
shape)))
(defn contained-in?
"Check if a shape is contained in the
provided selection rect."
[shape selrect]
(let [sx1 (:x selrect)
sx2 (+ sx1 (:width selrect))
sy1 (:y selrect)
sy2 (+ sy1 (:height selrect))
rx1 (:x shape)
rx2 (+ rx1 (:width shape))
ry1 (:y shape)
ry2 (+ ry1 (:height shape))]
(and (neg? (- (:y selrect) (:y shape)))
(neg? (- (:x selrect) (:x shape)))
(pos? (- (+ (:y selrect)
(:height selrect))
(+ (:y shape)
(:height shape))))
(pos? (- (+ (:x selrect)
(:width selrect))
(+ (:x shape)
(:width shape)))))))
;; TODO: maybe remove, seems it not used anymore.
(defn translate-coords
"Given a shape and initial coords, transform
it mapping its coords to new provided initial coords."
([shape x y]
(translate-coords shape x y -))
([shape x y op]
(let [x' (:x shape)
y' (:y shape)]
(assoc shape :x (op x' x) :y (op y' y)))))
;; This function will be deleted when selrect is implemented properly
(defn parent-satisfies?
"Resolve the first parent that satisfies a condition."
[{:keys [group] :as shape} pred]
(let [shapes-by-id (:shapes-by-id @st/state)]
(if group
(loop [parent (get shapes-by-id group)]
(cond
(pred parent) true
(:group parent) (recur (get shapes-by-id (:group parent)))
:else false))
false)))