arthur/frontend/test/arthur/domain/gesture_test.cljs

(ns arthur.domain.gesture-test
  (:require [cljs.test :refer [deftest is testing]]
            [arthur.demo.take :as take]
            [arthur.domain.channel :as ch]
            [arthur.domain.clip :as clip]
            [arthur.domain.gesture :as gesture]
            [arthur.domain.nest :as nest]
            [arthur.domain.node :as node]
            [arthur.domain.paint :as paint]
            [arthur.domain.palette :as pal]
            [arthur.domain.pick :as pick]))

(def ^:private u #uuid "00000000-0000-4000-8000-0000000000e1")
(def ^:private v #uuid "00000000-0000-4000-8000-0000000000e2")

(defn- two-down
  "A shape inside :box, placed turned and scaled unevenly in :mid, placed turned
  and doubled in :main — so nothing lines up by accident."
  []
  (let [turn (fn [c host id pos rot k]
               (update-in c [:symbols host :nodes id :channels] merge
                          {[:xform :pos]   (ch/framed pos)
                           [:xform :rot]   (ch/framed rot)
                           [:xform :scale] (ch/framed k)}))]
    (-> (clip/blank)
        (assoc-in [:symbols :mid] {:id :mid :frames 40 :nodes {}})
        (assoc-in [:symbols :box] {:id :box :frames 30 :nodes {}})
        (clip/place-symbol nil :main :mid 10 u nil)
        (clip/place-symbol nil :mid :box 2 v nil)
        (turn :main u [40 20] (/ js/Math.PI 2) [2 2])
        (turn :mid v [5 -3] 0.3 [1.5 0.5])
        (paint/new-shape :box :shape 4 [0 0 10 0 5 10] :brow))))

(defn- drawn [c path]
  (partition 2 (take 6 (array-seq (:pts (first (filter #(= path (:node %))
                                                         ((clip/resolver c :main nil pal/index-of nil) 16))))))))

(defn- near? [a b] (every? #(< (js/Math.abs %) 1e-9) (map - (flatten a) (flatten b))))

(defn- pivot-of
  "The parent-space pivot the stage would derive for this node at this frame —
  `begin!`'s one line, so a test drags about the same point the stage does."
  [c st sid id frame v0]
  (gesture/pivot v0 ((pick/bounds-of c st sid (get-in c [:symbols sid :nodes id])) frame)))

(defn- dragged [c path f vs-fn]
  (let [{:keys [sid id frame] :as pl} (nest/placement c nil :main path 16)
        v0 (gesture/values (get-in c [:symbols sid :nodes id]) frame nil)]
    (gesture/apply-values c sid id frame
                          (vs-fn pl v0 (pivot-of c nil sid id frame v0)))))

(deftest a-shape-two-symbols-down-moves-under-the-pointer
  (doseq [path [[u] [u v] [u v :shape]]]
    (let [c     (two-down)
          moved (dragged c path 16 (fn [pl v0 _] (gesture/move pl v0 [30 30] [37 26])))]
      (is (near? (map (fn [[x y]] [(+ x 7) (- y 4)]) (drawn c [u v :shape]))
                 (drawn moved [u v :shape]))
          (str "moving " path " by (7, -4) on the stage moves the shape by (7, -4)")))))

(deftest a-buffered-performance-take-becomes-one-set-of-authored-keys
  (let [c   (paint/new-shape (clip/blank) :main :shape 0 [0 0 10 0 5 10] :brow)
        out (gesture/apply-take
             c {[:main :shape]
                {3 {[:xform :pos] [10 20] [:xform :rot] 0.25}
                 4 {[:xform :pos] [12 22] [:xform :rot] 0.5}}})]
    (is (= {3 [10 20], 4 [12 22]}
           (get-in out [:symbols :main :nodes :shape :channels [:xform :pos] :keys])))
    (is (= {3 0.25, 4 0.5}
           (get-in out [:symbols :main :nodes :shape :channels [:xform :rot] :keys])))
    (is (= :linear
           (get-in out [:symbols :main :nodes :shape :channels [:xform :pos] :interp])))))

(deftest turning-keeps-the-pivot-where-it-is
  ;; The shape's geometry is [0 0 10 0 5 10], so the middle of what it draws is
  ;; (5, 5) in its own coordinates. NOTHING STORES THAT: the turn solves for the
  ;; `pos` that holds it still, which is the whole of why the rest goes round it.
  (let [c    (two-down)
        path [u v :shape]
        {:keys [world]} (nest/placement c nil :main path 16)
        pivot #(let [out (js/Float64Array. 2)]
                 (vec (array-seq (node/apply-pt! out 0 (:world (nest/placement % nil :main path 16)) 5 5))))
        turned (dragged c path 16 #(gesture/turn %2 %3 0.7))]
    (is (some? world))
    (is (near? (pivot c) (pivot turned)) "the middle of the drawing stays put")
    (is (not (near? (drawn c path) (drawn turned path))) "and the rest goes round it")
    (is (contains? (get-in turned [:symbols :box :nodes :shape :channels]) [:xform :pos])
        "a turn writes pos as well as rot — that is what makes it happen about a point")))

(deftest scaling-takes-the-grabbed-point-to-the-pointer
  (let [c    (two-down)
        path [u v :shape]
        {:keys [world]} (nest/placement c nil :main path 16)
        out  (js/Float64Array. 2)
        at   #(vec (array-seq (node/apply-pt! out 0 %1 %2 %3)))
        p0   (at world 10 0)
        p1   [(+ (first p0) 3) (- (second p0) 5)]
        grown (dragged c path 16 #(gesture/scale %1 %2 %3 p0 p1 false))
        w2   (:world (nest/placement grown nil :main path 16))]
    (is (near? p1 (at w2 10 0))
        "the corner grabbed is under the pointer, through a turned, unevenly scaled parent")
    (is (near? (at world 5 5) (at w2 5 5)) "about the middle of the drawing")))

;; ---------------------------------------------------------------------------
;; which way a corner drag goes
;;
;; `scale` takes the point under the pointer to the pointer, about the node's
;; PIVOT, and that is the whole of it — so which way a corner drag goes is
;; decided entirely by where the pivot is. In the middle of what the node draws,
;; which is where `gesture/pivot` derives it, pulling a corner away from the
;; middle makes the node bigger. At the node's coordinate ORIGIN — which is what
;; a node whose stored anchor had never been written got, and for head-local
;; geometry is the top-left corner of the FOOTAGE — every corner drag is a drag
;; away from a point off in the corner: the shape shrinks and slides while the
;; corner dutifully follows the pointer, which is what the bug looked like from
;; the outside.
;;
;; None of it is stored any more, so none of it can be absent or stale. These
;; tests used to need a freeze pass to have written the pivots they check.

(defn- at [m p] (let [out (js/Float64Array. 2)]
                  (vec (array-seq (node/apply-pt! out 0 m (first p) (second p))))))

(defn- handles
  "Where the stage would draw this node's box and pivot: its own bounds through
  its `:world`, and the MIDDLE OF THOSE BOUNDS, which is what `ui/stage`'s
  `handles` does. One `bounds-of` feeding both is the point — the cross cannot
  drift off the box, because it is the box's own middle."
  [c st open path f]
  (let [{:keys [sid id world frame]} (nest/placement c st open path f)
        n (get-in c [:symbols sid :nodes id])
        [x0 y0 x1 y1] ((pick/bounds-of c st sid n) frame)]
    {:corners (mapv #(at world %) [[x0 y0] [x1 y0] [x1 y1] [x0 y1]])
     :pivot   (at world [(/ (+ x0 x1) 2) (/ (+ y0 y1) 2)])}))

(defn- span
  "How big the box is, as the length of its diagonals — which does not care that
  a turned parent leaves it off the screen's axes."
  [{[a b c* d] :corners}]
  (+ (js/Math.hypot (- (first c*) (first a)) (- (second c*) (second a)))
     (js/Math.hypot (- (first d) (first b)) (- (second d) (second b)))))

(defn- corner-drag
  "Drag corner `i` of the node's box by `d`, exactly as the stage does: read the
  placement and the transform off the document AS IT IS NOW, scale from where
  the pointer went down to where it is."
  [c st open path f i d]
  (let [{:keys [sid id frame] :as pl} (nest/placement c st open path f)
        v0 (gesture/values (get-in c [:symbols sid :nodes id]) frame st)
        c* (pivot-of c st sid id frame v0)
        p0 (nth (:corners (handles c st open path f)) i)
        p1 (mapv + p0 d)]
    {:clip (gesture/apply-values c sid id frame (gesture/scale pl v0 c* p0 p1 false) false st)
     :p0 p0 :p1 p1}))

(defn- away
  "A pull of `k` stage pixels straight away from the pivot, from corner `i`."
  [{:keys [corners pivot]} i k]
  (let [[dx dy] (mapv - (nth corners i) pivot)
        len (max 1e-9 (js/Math.hypot dx dy))]
    [(* k (/ dx len)) (* k (/ dy len))]))

(deftest dragging-a-corner-away-from-the-middle-makes-it-bigger
  (doseq [[what c path f]
          [["a shape on its own"
            (paint/new-shape (clip/blank) :main :shape 4 [100 80 140 80 140 110 100 110] :brow)
            [:shape] 4]
           ["a shape two symbols down, through a turned and unevenly scaled parent"
            (two-down) [u v :shape] 16]]
          i (range 4)]
    (let [before (handles c nil :main path f)
          out    (corner-drag c nil :main path f i (away before i 6))
          in     (corner-drag c nil :main path f i (away before i -6))
          grown  (handles (:clip out) nil :main path f)
          shrunk (handles (:clip in) nil :main path f)]
      (is (< (span before) (span grown))
          (str what ", corner " i ": pulled away from the middle it got smaller"))
      (is (> (span before) (span shrunk))
          (str what ", corner " i ": pushed towards the middle it got bigger"))
      (is (near? (:p1 out) (nth (:corners grown) i))
          (str what ", corner " i ": the corner grabbed is not under the pointer"))
      (is (near? (:pivot before) (:pivot grown))
          (str what ", corner " i ": the pivot moved")))))

(deftest a-corner-pulled-up-and-left-grows-up-and-left
  ;; The report, literally: no turned parent in the way, so the box's corners are
  ;; the screen's, and the top-left one dragged further top-left has to make the
  ;; box bigger rather than smaller.
  (let [c (paint/new-shape (clip/blank) :main :shape 4 [100 80 140 80 140 110 100 110] :brow)
        before (handles c nil :main [:shape] 4)
        after  (handles (:clip (corner-drag c nil :main [:shape] 4 0 [-10 -10]))
                        nil :main [:shape] 4)
        [tl _ br _] (:corners after)]
    (is (= [100 80] (first (:corners before))) "corner 0 is the top left")
    (is (near? [90 70] tl) "the corner grabbed is under the pointer")
    (is (and (> (first br) 140) (> (second br) 110))
        "and the far corner went the other way, about the middle")
    (is (< (span before) (span after)) "so the shape is bigger")))

(deftest a-face-part-scales-about-its-own-middle
  ;; The whole measured rig, from `demo/take`: source-space geometry under a
  ;; dense head similarity, under the authored source placement, inside an
  ;; instance. The mouth's pivot used to sit at (-234, -395) on a 320x200 stage —
  ;; the top-left corner of the FOOTAGE, carried onto the stage — because its
  ;; stored anchor was never written: `freeze` refused to write one onto anything
  ;; measured, and rightly, since an anchor under a measured scale does not cancel
  ;; out. Deriving it removes the refusal along with the field. There is nothing
  ;; to write, so there is no node a pivot can be missing from.
  (let [{c :clip st :store} @take/frozen
        f 10]
    (doseq [path [[:face-1] [:face-1 :mouth] [:face-1 :eye-r]]]
      (let [before (handles c st :main path f)
            [px py] (:pivot before)]
        (is (and (< 0 px (:width c)) (< 0 py (:height c)))
            (str path "'s pivot " (pr-str (:pivot before)) " is off the stage"))
        (doseq [i (range 4)]
          (let [out   (corner-drag c st :main path f i (away before i 8))
                grown (handles (:clip out) st :main path f)]
            (is (< (span before) (span grown))
                (str path ", corner " i " pulled away from the middle got smaller"))
            (is (near? (:p1 out) (nth (:corners grown) i))
                (str path ", corner " i " is not under the pointer"))
            (is (near? (:pivot before) (:pivot grown))
                (str path ", corner " i ": the pivot moved"))))))))

(deftest every-node-in-a-face-can-have-its-transform-read
  ;; What a click near the eyes hit, and it took the stage down with it — in
  ;; `begin!` selecting the node, and again in `handles` drawing its pivot
  ;; cross. `values` asked its channels for a value WITHOUT the tier-2 store,
  ;; which is fine for every hand-placed node and throws the moment one of them
  ;; is dense: an iris follows the gaze, a brow follows the raise, a head
  ;; follows the measured similarity, and all three are ordinary things to
  ;; select. Over every node of a real take, so a new dense channel on any of
  ;; them is covered the day it is added.
  (let [{c :clip st :store} @take/frozen]
    (doseq [sid    [:main :face-1]
            [id n] (get-in c [:symbols sid :nodes])]
      (let [v (gesture/values n 10 st)]
        (is (map? v) (str sid "/" id " could not be read at all"))
        (is (every? #(or (number? %) (ch/nothing? %))
                    (concat (:pos v) (:scale v) (:skew v) [(:rot v)]))
            (str sid "/" id " did not read as numbers: " (pr-str v))))
      (when (node/measured? n)
        (is (thrown? js/Error (gesture/values n 10 nil))
            (str sid "/" id " has a dense transform, so reading it storeless"
                 " has to throw — otherwise this test proves nothing"))
        (is (string? (gesture/refusal n))
            (str sid "/" id " is measured but a drag on it is not refused"))))))

(deftest a-drag-starts-from-the-document-as-it-is-now
  ;; What `ui/stage`'s `loaded` is for. A drag reads the placement and the
  ;; transform when the pointer goes DOWN; reading them when the overlay last
  ;; rendered is the same code with a clip in it that predates the last edit, and
  ;; this is what that costs — the node is put back where it was before the
  ;; previous drag and only then moved, so it sits still under the press and
  ;; jumps on the first pointermove. Two drags have to compose.
  (let [c     (two-down)
        path  [u v :shape]
        once  (dragged c path 16 (fn [pl v0 _] (gesture/move pl v0 [30 30] [37 26])))
        twice (dragged once path 16 (fn [pl v0 _] (gesture/move pl v0 [30 30] [33 31])))
        ;; The same second drag, begun from the clip as it was BEFORE the first.
        stale (let [{:keys [sid id frame] :as pl} (nest/placement c nil :main path 16)
                    v0 (gesture/values (get-in c [:symbols sid :nodes id]) frame nil)]
                (gesture/apply-values once sid id frame
                                      (gesture/move pl v0 [30 30] [33 31])))]
    (is (near? (map (fn [[x y]] [(+ x 10) (- y 3)]) (drawn c path)) (drawn twice path))
        "(7, -4) then (3, 1) leaves the shape moved by (10, -3)")
    (is (near? (map (fn [[x y]] [(+ x 3) (+ y 1)]) (drawn c path)) (drawn stale path))
        "begun from the stale clip it lands where the FIRST drag never happened")
    (is (not (near? (drawn twice path) (drawn stale path)))
        "which is the jump, and it is the whole of the difference")))

(deftest a-drag-keys-a-keyed-channel-and-sets-a-framed-one
  (let [c     (update-in (two-down) [:symbols :mid :nodes v :channels [:xform :pos]]
                         (constantly (ch/keyed {0 [5 -3] 20 [9 -3]} :linear)))
        moved (dragged c [u v] 16 (fn [pl v0 _] (gesture/move pl v0 [0 0] [4 0])))
        pos   (get-in moved [:symbols :mid :nodes v :channels [:xform :pos]])
        rot   (dragged c [u v] 16 #(gesture/turn %2 %3 0.1))]
    (is (= #{0 4 20} (set (keys (:keys pos))))
        "a key on the instance's own frame — 16 of main is 6 of mid, 4 of its own — and the others kept")
    (is (= {:animated? false :value 0.4}
           (update (get-in rot [:symbols :mid :nodes v :channels [:xform :rot]]) :value
                   #(/ (js/Math.round (* 10 %)) 10)))
        "a channel with no keys has its one value changed")))

(deftest a-measured-transform-is-not-set-by-hand
  (is (string? (gesture/refusal {:channels {[:xform :pos] {:animated? true :dense {:stride 2}}}})))
  (is (nil? (gesture/refusal {:channels {[:xform :pos] (ch/keyed {0 [1 1]} :hold)}}))))

(deftest moving-a-measured-part-adds-an-authored-offset
  (let [key "measured-position"
        st {key {:data (js/Float32Array. #js [1 2 2 3])}}
        measured {:animated? true :dense {:store key :offset 0 :stride 2 :frames 2}}
        c (-> (clip/blank)
              (paint/new-shape :main :brow 0 [0 0 10 0 5 3] :brow)
              (assoc-in [:symbols :main :nodes :brow :channels [:xform :pos]] measured))
        once (gesture/apply-values c :main :brow 0 {[:xform :pos] [4 6]} false st)
        twice (gesture/apply-values once :main :brow 0 {[:xform :pos] [5 8]} false st)
        pos #(get-in % [:symbols :main :nodes :brow :channels [:xform :pos]])]
    (is (= (:dense measured) (:dense (pos twice))) "the measured base survives")
    (is (= [5 8] (ch/value-at (pos twice) 0 st)) "the brow lands under the pointer")
    (is (= [6 9] (ch/value-at (pos twice) 1 st))
        "its measured motion continues underneath the authored offset")
    (is (= 1 (count (:over (pos twice)))) "repeated drags update one correction layer")))

(deftest a-click-selects-the-level-figma-would
  (let [hit [:a :b :c :shape]]
    (testing "choose"
      (is (= [:a] (pick/choose nil hit false)) "the thing in the open symbol")
      (is (= hit (pick/choose nil hit true)) "⌘ goes to the shape")
      (is (= [:a :b] (pick/choose [:a :b] hit false)) "inside what is selected keeps it")
      (is (= [:a :x] (pick/choose [:a :b] [:a :x :y] false)) "beside it, at the same depth")
      (is (= [:z] (pick/choose [:a :b] [:z :y] false)) "elsewhere, from the top")
      (is (nil? (pick/choose [:a] nil false)) "nothing, on nothing"))
    (testing "deeper"
      (is (= [:a :b] (pick/deeper [:a] hit)))
      (is (= hit (pick/deeper hit hit)) "not past the shape")
      (is (= [:z] (pick/deeper [:z] hit)) "and not into something else"))))

(deftest the-topmost-op-under-the-point-is-hit
  (let [sq  (fn [node x0] {:kind :poly :node node :n 4
                           :pts (js/Float64Array. #js [x0 0 (+ x0 10) 0 (+ x0 10) 10 x0 10])})
        ops [(sq :under 0) (sq [u :over] 5) {:kind :disc :node :dot :cx 50 :cy 50 :r 1}]]
    (is (= [u :over] (pick/hit ops [7 5])) "the later op is drawn on top")
    (is (= [:under] (pick/hit ops [2 5])))
    (is (= [:dot] (pick/hit ops [52.5 50])) "a few-pixel shape can be missed by a little")
    (is (nil? (pick/hit ops [30 30])))))

(deftest a-marquee-selects-visible-objects-at-one-depth
  (let [sq  (fn [path x0] {:kind :poly :node path :n 4
                            :pts (js/Float64Array.
                                  #js [x0 0 (+ x0 10) 0 (+ x0 10) 10 x0 10])})
        ops [(sq [:left :inside] 0) (sq [:right :inside] 20) (sq [:away] 80)]]
    (is (= [[:left] [:right]] (pick/in-rect ops [-2 -2 35 12] 1))
        "a fresh marquee chooses objects in the open symbol")
    (is (= [[:left :inside] [:right :inside]] (pick/in-rect ops [-2 -2 35 12] 2))
        "an existing deep selection keeps the marquee at that depth")
    (is (= [[:left]] (pick/in-rect ops [5 5 6 6] 1))
        "intersection, rather than full containment, makes small objects selectable")))

(deftest an-instances-box-is-what-its-symbol-draws
  (let [c (two-down)
        {:keys [frame]} (nest/placement c nil :main [u v] 16)]
    (is (= [0 0 10 10] ((pick/bounds-of c nil :mid (get-in c [:symbols :mid :nodes v])) frame)))
    (is (= [0 0 10 10] ((pick/bounds-of c nil :box (get-in c [:symbols :box :nodes :shape])) 4)))))