From 8f09b7b47f1c735d848235597cb67fa28c20b6f1 Mon Sep 17 00:00:00 2001 From: Your Name Date: Fri, 2 Oct 2026 09:06:28 -0400 Subject: [PATCH] Unify lane overlap and nested timing --- frontend/src/arthur/domain/nest.cljs | 2 +- frontend/src/arthur/domain/span.cljs | 112 ++++++++++----------- frontend/src/arthur/events/ui.cljs | 14 ++- frontend/src/arthur/ui/timeline.cljs | 63 +++++++----- frontend/test/arthur/domain/nest_test.cljs | 12 +++ frontend/test/arthur/events/lane_test.cljs | 23 +++++ 6 files changed, 140 insertions(+), 86 deletions(-) diff --git a/frontend/src/arthur/domain/nest.cljs b/frontend/src/arthur/domain/nest.cljs index 8558ae8..210cca7 100644 --- a/frontend/src/arthur/domain/nest.cljs +++ b/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`. diff --git a/frontend/src/arthur/domain/span.cljs b/frontend/src/arthur/domain/span.cljs index 1efa712..a578c41 100644 --- a/frontend/src/arthur/domain/span.cljs +++ b/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 - (if ripple? - (reduce (fn [ns sibling] - (update-in ns [(:id sibling) :time :at] (fnil + 0) delta)) - resized later) - (if (pos? delta) - (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))))) + changed (reduce (fn [ns sibling] + (update-in ns [(:id sibling) :time :at] (fnil + 0) delta)) + resized later)] + (claim clip sid changed id extent nil))))) (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)) - earlier (when node - (filter #(<= (second (node/placed-span %)) old-in) - (siblings clip sid nodes id)))] + [old-in hi] (when node (node/placed-span node))] (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 - (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))))) + :else (claim clip sid (assoc nodes id (edged node :in to)) id :keep nil)))) (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)] - (if (:refused room) - 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))))))) + (let [placed (update-in n [:time :at] (fnil + 0) (- at lo))] + (claim clip sid (assoc nodes id placed) id extent remainder-id))))) (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)] - (if (:refused room) - room - (place (assoc-in (:clip room) [:symbols drawing-id] - {:id drawing-id :name (name drawing-id) :fps (clip/fps clip sid) :frames 1 :nodes {}}) - sid id drawing-id at extent false)))))) + (let [c (assoc-in clip [:symbols drawing-id] + {:id drawing-id :name (name drawing-id) + :fps (clip/fps clip sid) :frames 1 :nodes {}}) + nodes (assoc nodes id (held id drawing-id at))] + (claim c sid nodes id extent remainder-id))))) (defn make-unique "Point clip `id` at a private copy of its content, leaving every other diff --git a/frontend/src/arthur/events/ui.cljs b/frontend/src/arthur/events/ui.cljs index f8b0e15..73c1542 100644 --- a/frontend/src/arthur/events/ui.cljs +++ b/frontend/src/arthur/events/ui.cljs @@ -696,9 +696,9 @@ ::drop-clear (fn [db _] (update db :ui dissoc :drop))) -(defn drop-destination - "Which symbol a drop lands in and on which of its frames: `{:clip :sid :at - :path}`, or `{:refused why}`. +(defn drop-destination-at + "Which symbol a drop on `target` lands in and on which of its frames: + `{: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] diff --git a/frontend/src/arthur/ui/timeline.cljs b/frontend/src/arthur/ui/timeline.cljs index a05aac5..d87b9d6 100644 --- a/frontend/src/arthur/ui/timeline.cljs +++ b/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 - symbol it lives in. See `node/time-of`. + "Where a frame of a node's OWN time sits in the symbol it lives in. + 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)] - (if (and (zero? at) (= 1 rate)) - identity - (fn [f] (+ at (/ f rate)))))) + (time->parent (node/time-of n))) (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)] - (walk source path depth (comp self #(+ at (/ % rate)))) + (if-let [source-time (clip/source-time clip sid n)] + (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!)) - of (rf/dispatch [::pb/open-symbol of]))) - :on-key-down (when lane? - (fn [^js e] - (when (= "F2" (.-key e)) - (.preventDefault e) - (begin-rename!))))} + (when of + (rf/dispatch [::pb/open-symbol of])))} ;; 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) - (:grab drag))))] + (max 0 (- target-at (:grab drag))))] (when (and drag hint) (reset! hint {:x (.-clientX e) :y (.-clientY e) diff --git a/frontend/test/arthur/domain/nest_test.cljs b/frontend/test/arthur/domain/nest_test.cljs index d224a4f..aba75ff 100644 --- a/frontend/test/arthur/domain/nest_test.cljs +++ b/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))))) diff --git a/frontend/test/arthur/events/lane_test.cljs b/frontend/test/arthur/events/lane_test.cljs index 939ce3c..a282069 100644 --- a/frontend/test/arthur/events/lane_test.cljs +++ b/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 #{})]