noe/arthur
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Unify lane overlap and nested timing

Browse source
This commit is contained in:
Your Name 2026-10-02 09:06:28 -04:00
parent 1b2b4ad3d2
commit 8f09b7b47f
6 changed files with 140 additions and 86 deletions
Download patch file Download diff file Expand all files Collapse all files

2
frontend/src/arthur/domain/nest.cljs
View file

@ -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`.

112
frontend/src/arthur/domain/span.cljs
View file

@ -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

14
frontend/src/arthur/events/ui.cljs
View file

@ -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]

63
frontend/src/arthur/ui/timeline.cljs
View file

@ -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)

12
frontend/test/arthur/domain/nest_test.cljs
View file

@ -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)))))

23
frontend/test/arthur/events/lane_test.cljs
View file

@ -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 #{})]