Unify lane overlap and nested timing

frontend/src/arthur/domain/nest.cljs

@@ -454,7 +454,7 @@
         ;; a boundary can be rolled depend on which of them `some` reaches
         ;; first. `finish` does the same `problems` check and the overlap one
         ;; too, so this is less code and one fewer invariant to remember.
-        (span/finish clip (:sid here) moved id :grow-symbol)))))
+        (span/claim clip (:sid here) moved id :grow-symbol (random-uuid))))))
 
 (defn resize-out
   "Move the right edge of the node at `path` by `df` frames of `open`.

frontend/src/arthur/domain/span.cljs

@@ -144,6 +144,47 @@
   [n which f]
   (assoc-in n [:span (case which :in 0 :out 1)] (local n f)))
 
+(defn claim
+  "Commit proposed `nodes`, with `id` claiming its interval in lane mode.
+
+  This is the one difference between editing a lane and a composition.  In a
+  composition it is exactly `finish`.  In a lane, immediately before that same
+  commit, clips covered by the edited one are removed and clips crossing either
+  edge are trimmed.  A clip crossing both edges is split and therefore needs a
+  caller-supplied `remainder-id`."
+  [clip sid nodes id extent remainder-id]
+  (let [n (get nodes id)
+        lane-child? (and (symbol/lane? (clip/symbol clip sid))
+                         n (nil? (:parent n)) (node/placed-span n))]
+    (if-not lane-child?
+      (finish clip sid nodes id extent)
+      (let [[a b] (node/placed-span n)
+            others (remove #(= id (:id %)) (symbol/children nodes))
+            spanning (first (filter #(let [[lo hi] (node/placed-span %)]
+                                       (and (< lo a) (> hi b)))
+                                    others))]
+        (if (and spanning (or (nil? remainder-id) (contains? nodes remainder-id)))
+          {:refused "claiming time inside one clip needs a free ID for its remainder"}
+          (finish
+           clip sid
+           (reduce
+            (fn [ns other]
+              (let [oid (:id other)
+                    [lo hi] (node/placed-span other)]
+                (cond
+                  (or (<= hi a) (>= lo b)) ns
+                  (and (< lo a) (> hi b))
+                  (-> ns
+                      (assoc oid (edged other :out a))
+                      (assoc remainder-id
+                             (assoc (edged other :in b) :id remainder-id
+                                    :z (str "a-" remainder-id))))
+                  (and (>= lo a) (<= hi b)) (dissoc ns oid)
+                  (< lo a) (assoc ns oid (edged other :out a))
+                  :else (assoc ns oid (edged other :in b)))))
+            nodes others)
+           id extent))))))
+
 (defn host-frame
   "Symbol frame `f` as a frame of the space node `id` is POSITIONED in — its
   parent's — which is the frame space every command here takes its coordinate
@@ -335,7 +376,7 @@
   (let [nodes (get-in clip [:symbols sid :nodes])
         {:keys [node refused]} (subject nodes id)
         [lo old-out] (when node (node/placed-span node))
-        later (when node
+        later (when (and node ripple?)
                 (filter #(>= (first (node/placed-span %)) old-out)
                         (siblings clip sid nodes id)))]
     (cond
@@ -346,22 +387,10 @@
       :else
       (let [delta (- to old-out)
             resized (assoc nodes id (edged node :out to))
-            changed
+            changed (reduce (fn [ns sibling]
-            (if ripple?
-              (reduce (fn [ns sibling]
                               (update-in ns [(:id sibling) :time :at] (fnil + 0) delta))
-                      resized later)
+                            resized later)]
-              (if (pos? delta)
+        (claim clip sid changed id extent nil)))))
-                (reduce
-                 (fn [ns sibling]
-                   (let [[s e] (node/placed-span sibling)]
-                     (cond
-                       (>= s to) ns
-                       (<= e to) (dissoc ns (:id sibling))
-                       :else (assoc ns (:id sibling) (edged sibling :in to)))))
-                 resized later)
-                resized))]
-        (finish clip sid changed id extent)))))
 
 (defn resize-in
   "Put clip `id`'s left edge at parent frame `to`. Shrinking leaves a gap;
@@ -369,29 +398,14 @@
   [clip sid id to]
   (let [nodes (get-in clip [:symbols sid :nodes])
         {:keys [node refused]} (subject nodes id)
-        [old-in hi] (when node (node/placed-span node))
+        [old-in hi] (when node (node/placed-span node))]
-        earlier (when node
-                  (filter #(<= (second (node/placed-span %)) old-in)
-                          (siblings clip sid nodes id)))]
     (cond
       refused {:refused refused}
       (not (integer? to)) {:refused "an edge goes to a whole frame"}
       (not (< to hi)) {:refused "a clip must keep at least one frame"}
       (neg? to) {:refused "a clip cannot begin before the shot"}
       (= to old-in) {:clip clip :selection id}
-      :else
+      :else (claim clip sid (assoc nodes id (edged node :in to)) id :keep nil))))
-      (let [resized (assoc nodes id (edged node :in to))
-            changed (if (< to old-in)
-                      (reduce
-                       (fn [ns sibling]
-                         (let [[s e] (node/placed-span sibling)]
-                           (cond
-                             (<= e to) ns
-                             (>= s to) (dissoc ns (:id sibling))
-                             :else (assoc ns (:id sibling) (edged sibling :out to)))))
-                       resized earlier)
-                      resized)]
-        (finish clip sid changed id :keep)))))
 
 (defn roll
   "Move the shared boundary between adjacent clips `left-id` and `right-id`.
@@ -460,17 +474,6 @@
         ;; selected rather than being handed a clip it did not ask for.
         (finish clip sid nodes (when spanning id) :keep)))))
 
-(defn- cleared
-  "`clip` with frames `[at (+ at duration))` of `sid` emptied where `sid` is drawn
-  as a lane, and untouched where it is not: outside lane mode a placement does not
-  claim time, because being on screen together is what compositing IS.
-
-  `{:clip c}` or `{:refused why}`, so one `if-let` covers both."
-  [clip sid at duration remainder-id]
-  (if-not (symbol/lane? (clip/symbol clip sid))
-    {:clip clip}
-    (blank clip sid [at (+ at duration)] {:id remainder-id})))
-
 (defn extend-hold
   "Change one held clip's duration by `delta` frames and ripple its later
   siblings. Keys, source clocks and the clips' own channels stay put.
@@ -528,12 +531,8 @@
       (and remainder-id (contains? nodes remainder-id))
       {:refused "the remainder clip needs a free ID"}
       :else
-      (let [room (cleared clip sid at duration remainder-id)]
+      (let [placed (update-in n [:time :at] (fnil + 0) (- at lo))]
-        (if (:refused room)
+        (claim clip sid (assoc nodes id placed) id extent remainder-id)))))
-          room
-          (let [placed (update-in n [:time :at] (fnil + 0) (- at lo))
-                nodes (assoc (get-in (:clip room) [:symbols sid :nodes]) id placed)]
-            (finish (:clip room) sid nodes id extent)))))))
 
 (defn place-symbol
   "Materialize an instance of `source-id`, then place it into `sid` at `at`.
@@ -746,12 +745,11 @@
                    "the remainder clip needs a free ID different from the new clip"
                    (clip/symbol clip drawing-id) "the new drawing ID is already used")]
       {:refused why}
-      (let [room (cleared clip sid at 1 remainder-id)]
+      (let [c (assoc-in clip [:symbols drawing-id]
-        (if (:refused room)
+                        {:id drawing-id :name (name drawing-id)
-          room
+                         :fps (clip/fps clip sid) :frames 1 :nodes {}})
-          (place (assoc-in (:clip room) [:symbols drawing-id]
+            nodes (assoc nodes id (held id drawing-id at))]
-                           {:id drawing-id :name (name drawing-id) :fps (clip/fps clip sid) :frames 1 :nodes {}})
+        (claim c sid nodes id extent remainder-id)))))
-                 sid id drawing-id at extent false))))))
 
 (defn make-unique
   "Point clip `id` at a private copy of its content, leaving every other

frontend/src/arthur/events/ui.cljs

@@ -696,9 +696,9 @@
  ::drop-clear
  (fn [db _] (update db :ui dissoc :drop)))
 
-(defn drop-destination
+(defn drop-destination-at
-  "Which symbol a drop lands in and on which of its frames: `{:clip :sid :at
+  "Which symbol a drop on `target` lands in and on which of its frames:
-  :path}`, or `{:refused why}`.
+  `{:clip :sid :at :path}`, or `{:refused why}`.
 
   ONE RULE AND EVERY DROP ASKS IT — a symbol from the pool, a sound, and a video
   brought in as a take alike. The pointer names a ROW, `target`, and a row leads
@@ -714,12 +714,11 @@
   `:clip` is handed back unchanged and is in the result only so the callers that
   used to be given a document with a freshly made lane in it go on reading one
   thing."
-  [db document st frame target]
+  [document st open frame target]
   (let [target (if (vector? target)
                  (let [[_ sid id path] target]
                    {:sid sid :id id :path path})
                  target)
-        open (get-in db [:ui :open])
         path (cond
                (nil? target) []
                (= :instance (get-in document [:symbols (:sid target)
@@ -732,6 +731,11 @@
       (not (integer? at)) {:refused "the drop is not on one frame of that symbol"}
       :else {:clip document :sid sid :at at :path path})))
 
+(defn drop-destination
+  "`drop-destination-at` from the symbol currently open in `db`."
+  [db document st frame target]
+  (drop-destination-at document st (get-in db [:ui :open]) frame target))
+
 (defn landed
   "`db` after a drop that produced `result`, with `uuid` selected."
   [db {:keys [sid path]} uuid result]

frontend/src/arthur/ui/timeline.cljs

@@ -43,9 +43,16 @@
 ;; ---------------------------------------------------------------------------
 ;; the rows
 
+(defn- time->parent
+  "The inverse of a time map: where one of its output frames sits in its input."
+  [{:keys [at rate]}]
+  (if (and (zero? at) (= 1 rate))
+    identity
+    (fn [f] (+ at (/ f rate)))))
+
 (defn- local->parent
-  "The inverse of a node's time map: where a frame of its OWN time sits in the
+  "Where a frame of a node's OWN time sits in the symbol it lives in.
-  symbol it lives in. See `node/time-of`.
+  See `node/time-of`.
 
   Two frame spaces meet at every node and mixing them up is the bug this exists
   to prevent: a placement `:at 48` whose scale is keyed at 0 has that key on
@@ -56,10 +63,7 @@
   frame the exposure grid never samples is still authored on that frame, and that
   is where the row should show it."
   [n]
-  (let [{:keys [at rate]} (node/time-of n)]
+  (time->parent (node/time-of n)))
-    (if (and (zero? at) (= 1 rate))
-      identity
-      (fn [f] (+ at (/ f rate))))))
 
 (defn- keyed-frames [ch] (some-> (:keys ch) keys sort))
 
@@ -131,8 +135,8 @@
             ;; the key positions, and the bars that would imply them. Refuse
             ;; rather than guess, without refusing the whole subtree.
             (when-let [source (and (= :instance (:kind n)) (node/source n))]
-              (if-let [{:keys [at rate]} (clip/source-time clip sid n)]
+              (if-let [source-time (clip/source-time clip sid n)]
-                (walk source path depth (comp self #(+ at (/ % rate))))
+                (walk source path depth (comp self (time->parent source-time)))
                 (mapv (fn [row]
                         (-> row
                             (assoc :keys [] :unmapped? true)
@@ -244,6 +248,13 @@
                              self     (comp parent-map (local->parent n))
                              source-sym (when (= :instance (:kind n))
                                           (clip/symbol clip (node/source n)))
+                             ;; `self` maps the instance's local clock. Rows of
+                             ;; the symbol it places use its source clock too,
+                             ;; including the native-FPS ratio.
+                             source-self (if-let [t (and source-sym
+                                                         (clip/source-time clip sid n))]
+                                           (comp self (time->parent t))
+                                           self)
                              lane?    (symbol/lane? source-sym)
                              clips    (when lane? (symbol/children (:nodes source-sym)))
                              span     (mapv parent-map
@@ -283,13 +294,13 @@
                                                        :label (or (get-in clip [:symbols (node/source child) :name])
                                                                   (some-> (node/source child) name))
                                                        :source (node/source child)
-                                                       :span (mapv self (node/placed-span child))
+                                                       :span (mapv source-self (node/placed-span child))
                                                        ;; The clip's own keys, on the
                                                        ;; block, so a collapsed lane
                                                        ;; still says where it changes.
                                                        :keys (into []
                                                                    (comp (mapcat keyed-frames)
-                                                                         (map (comp self (local->parent child)))
+                                                                         (map (comp source-self (local->parent child)))
                                                                          (distinct))
                                                                    (vals (node/channels child)))
                                                        :select [:node (node/source n) (:id child)
@@ -302,7 +313,7 @@
                                             ;; The one clip an expanded lane opens.
                                             (into (when lane?
                                                     (if-let [child (first (filter #(under? (conj rpath (:id %))) clips))]
-                                                      (portal (node/source n) rpath (inc depth) self child)
+                                                      (portal (node/source n) rpath (inc depth) source-self child)
                                                       [{:path (conj rpath ::portal)
                                                         :depth (inc depth)
                                                         :kind :hint
@@ -587,7 +598,6 @@
                                    (if (= :instance node-kind) " drop-into" " drop-group"))))
                    :style {:padding-left (str (+ 4 (* 11 depth)) "px")}
                    :title label
-                   :tab-index (when lane? 0)
                    :ref (when (and select (= select selection)) (reveal selection))
                    ;; A LABEL AIMS. Clicking a row's name says "I am working
                    ;; here", which is a statement about a place in the document;
@@ -597,13 +607,8 @@
                    :on-click #(when select (rf/dispatch [::ui/aim select]))
                    ;; An instance's row opens the symbol it places, as a tab.
                    :on-double-click (fn [^js e]
-                                      (cond lane? (do (.stopPropagation e) (begin-rename!))
+                                      (when of
-                                            of (rf/dispatch [::pb/open-symbol of])))
+                                        (rf/dispatch [::pb/open-symbol of])))}
-                   :on-key-down (when lane?
-                                  (fn [^js e]
-                                    (when (= "F2" (.-key e))
-                                      (.preventDefault e)
-                                      (begin-rename!))))}
             ;; A node's row can be dragged onto another: onto an instance's, to
             ;; go inside the symbol it places; onto any other node's, to be
             ;; grouped with it into a new one; onto an edge of either, to be
@@ -667,7 +672,7 @@
        node?  [:span.kind (if via (str "· in " via) (str "·" (name node-kind)))])
      (when lane?
        [:button.tl-rename
-        {:title "rename lane (F2)"
+        {:title "rename lane"
          :on-click (fn [^js e] (.stopPropagation e) (begin-rename!))}
         "✎"])
      ;; A face's row is where its own footage is switched on, next to solo
@@ -734,10 +739,22 @@
                                              (not= (:select under) (:selection drag)))
                                     under)
                             [target-el target] (when (and drag (not shift?)) (lane-under e))
-                            landing? (some? target)
+                            target-at (when target
+                                        (frame-under e frames target-el))
+                            ;; A cel moved on its OWN lane is a normal slide.
+                            ;; Resolve the row under the pointer before calling
+                            ;; it a transfer: comparing the displayed rows is
+                            ;; not enough when the lane is reached through an
+                            ;; instance.  This leaves one slide gesture and one
+                            ;; coordinate conversion; lane overlap trimming is
+                            ;; the domain command's only additional policy.
+                            target-sid (when target
+                                         (:sid (ui/drop-destination-at
+                                                clip store open target-at target)))
+                            landing? (and target-sid
+                                          (not= target-sid (nth (:selection drag) 1)))
                             target-frame (when landing?
-                                           (max 0 (- (frame-under e frames target-el)
+                                           (max 0 (- target-at (:grab drag))))]
-                                                     (:grab drag))))]
                         (when (and drag hint)
                           (reset! hint
                                   {:x (.-clientX e) :y (.-clientY e)

frontend/test/arthur/domain/nest_test.cljs

@@ -356,3 +356,15 @@
     (is (= [22 23] (node/placed-span (get-in slid [:symbols :lane :nodes :b]))))
     (is (= 1 (:rate (get-in slid [:symbols :lane :nodes :b :time])))
         "and the rest of its map is still there")))
+
+(deftest sliding-in-a-lane-claims-overlapped-time
+  ;; The gesture is `nest/slide` in both display modes.  Lane mode contributes
+  ;; only the placement rule at commit: the moved cel replaces what it covers.
+  (let [c (on-twos)
+        r (nest/slide c :lane [:b] -14)
+        slid (:clip r)]
+    (is (nil? (:refused r)) (:refused r))
+    (is (= [5 6] (node/placed-span (get-in slid [:symbols :lane :nodes :b]))))
+    (is (nil? (get-in slid [:symbols :lane :nodes :a]))
+        "a fully covered neighbor is removed")
+    (is (empty? (clip/problems slid)))))

frontend/test/arthur/events/lane_test.cljs

@@ -63,6 +63,29 @@
             [:node :main :insert [:insert]]]
            (mapv :select (:cels lane))))))
 
+(deftest a-nested-lane-is-drawn-in-the-open-symbols-frame-rate
+  (let [child {:id :cel :kind :instance :z "a" :span [0 2]
+               :time {:at 4 :rate 1}
+               :source {:symbol :drawing}
+               :playback {:in 0 :speed 0 :end :stop}}
+        placed {:id :take :kind :instance :z "a" :span [0 12]
+                :time {:at 0 :rate 1}
+                :source {:symbol :lane}
+                :playback {:in 0 :speed 1 :end :stop}}
+        doc (-> (clip/blank)
+                (assoc :fps 12)
+                (assoc-in [:symbols :main :fps] 12)
+                (assoc-in [:symbols :main :frames] 12)
+                (assoc-in [:symbols :main :nodes] {:take placed})
+                (assoc-in [:symbols :lane]
+                          {:id :lane :fps 24 :frames 24 :display :lane
+                           :nodes {:cel child}})
+                (assoc-in [:symbols :drawing]
+                          {:id :drawing :fps 24 :frames 1 :nodes {}}))
+        lane (first (filter :lane? (timeline/rows doc :main #{})))]
+    (is (= [[2 3]] (mapv :span (:cels lane)))
+        "native frames 4–6 occupy ruler frames 2–3 at twice the frame rate")))
+
 (deftest an-ordinary-symbol-keeps-a-row-per-node
   (let [doc (update-in (fixture/document) [:symbols :main] dissoc :display)
         rows (timeline/rows doc :main #{})]