diff --git a/src/uxbox/util/geom.cljs b/src/uxbox/util/geom.cljs new file mode 100644 index 0000000000..5059497a56 --- /dev/null +++ b/src/uxbox/util/geom.cljs @@ -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 + +(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)))