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

Unify clip placement across symbol modes

Browse source
This commit is contained in:
Your Name 2026-10-01 20:09:35 -04:00
parent e459307a4a
commit 93f5112bb3
5 changed files with 136 additions and 117 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -474,9 +474,45 @@
nodes later)]
(finish clip sid nodes id extent)))))
(defn place-node
"Place the already-materialized, direct child `n` into symbol `sid` at `at`.
THIS IS THE PLACEMENT RULE. Materializing a symbol instance, an audio node, or
imported content is deliberately somebody else's job; once it is a node, its
origin no longer matters. The destination alone decides the edit:
- an ordinary symbol attaches it and permits overlap;
- a lane symbol first clears the interval it claims.
The caller hands this function a node not currently present in the destination.
Its duration, channels, source clock and identity are preserved; only its
parent-space start changes. Returns the ordinary command result shape."
[clip sid n at {:keys [extent remainder-id] :or {extent :keep}}]
(let [sym (clip/symbol clip sid)
nodes (:nodes sym)
id (:id n)
[lo hi] (when n (node/placed-span n))
duration (when (and lo hi) (- hi lo))]
(cond
(nil? sym) {:refused "there is no destination symbol"}
(nil? n) {:refused "there is no clip to place"}
(contains? nodes id) {:refused "the destination already uses that clip ID"}
(some? (:parent n)) {:refused "only a direct child can be placed in a symbol"}
(not (and (integer? at) (not (neg? at))))
{:refused "a position is a nonnegative whole frame"}
(not (pos? duration)) {:refused "the clip has no frames to place"}
(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)))))))
(defn place-symbol
"Place arbitrary symbol `source-id` into `sid` as a naturally playing clip at
frame `at`.
"Materialize an instance of `source-id`, then place it into `sid` at `at`.
IN A LANE the new clip claims its interval: existing clips under it are
trimmed, removed, or split, so the sequence stays a partition rather than
@ -488,25 +524,13 @@
{:keys [extent point remainder-id] :or {extent :keep}}]
(let [nodes (get-in clip [:symbols sid :nodes])
seeded (clip/place-symbol clip store sid source-id 0 id point)
n (get-in seeded [:symbols sid :nodes id])
duration (when n (- (second (node/placed-span n))
(first (node/placed-span n))))]
n (get-in seeded [:symbols sid :nodes id])]
(cond
(contains? nodes id) {:refused "the new clip ID is already used"}
(not (and (integer? at) (not (neg? at))))
{:refused "a position is a nonnegative whole frame"}
(nil? (clip/symbol clip source-id)) {:refused "there is no such symbol to place"}
(nil? n) {:refused "a symbol cannot go inside itself"}
(not (pos? duration)) {:refused "the symbol has no frames to place"}
(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 [nodes (assoc (get-in (:clip room) [:symbols sid :nodes]) id
(assoc-in n [:time :at] at))]
(finish (:clip room) sid nodes id extent)))))))
(place-node clip sid n at {:extent extent :remainder-id remainder-id}))))
(defn adopt
"Move an existing clip of `sid` to frame `at`, CLAIMING the time it lands on.
@ -516,28 +540,36 @@
is what a body drag does, and it is why `move` and this are two commands:
`move` refuses to disturb a neighbour, and a drag onto occupied time has
already said it means to."
[clip sid id at {:keys [extent remainder-id] :or {extent :keep}}]
[clip sid id at opts]
(let [nodes (get-in clip [:symbols sid :nodes])
n (get nodes id)
[lo hi] (when n (node/placed-span n))
duration (when (and lo hi) (- hi lo))]
n (get nodes id)]
(cond
(nil? n) {:refused "select a clip to move"}
(some? (:parent n)) {:refused "only a clip of the symbol itself is placed in its sequence"}
(not (and (integer? at) (not (neg? at))))
{:refused "a position is a nonnegative whole frame"}
(not (pos? duration)) {:refused "the clip has no frames to place"}
(and remainder-id (contains? nodes remainder-id))
{:refused "the remainder clip needs a free ID"}
:else
(let [room (cleared (assoc-in clip [:symbols sid :nodes]
(dissoc nodes id))
sid at duration remainder-id)]
(if (:refused room)
room
(let [moved (update-in n [:time :at] (fnil + 0) (- at lo))
nodes (assoc (get-in (:clip room) [:symbols sid :nodes]) id moved)]
(finish (:clip room) sid nodes id extent)))))))
(place-node (assoc-in clip [:symbols sid :nodes] (dissoc nodes id))
sid n at opts))))
(defn transfer
"Move direct child `id` from `from-sid` into `to-sid` at `at`.
Cross-symbol and same-symbol moves are deliberately the same composition:
detach, then `place-node`. The destination's mode—not the gesture, source, or
payload kind—decides whether occupied time is claimed."
[clip from-sid id to-sid at opts]
(let [from-nodes (get-in clip [:symbols from-sid :nodes])
n (get from-nodes id)]
(cond
(nil? n) {:refused "select a clip to move"}
(some? (:parent n)) {:refused "only a direct child can move between symbols"}
:else
(let [detached (assoc-in clip [:symbols from-sid :nodes] (dissoc from-nodes id))
result (place-node detached to-sid n at opts)]
(if-let [made (:clip result)]
(if-let [why (first (clip/problems made))]
{:refused why}
result)
result)))))
;; ---------------------------------------------------------------------------
;; putting drawings in a sequence

16
frontend/src/arthur/domain/symbol.cljs
View file

@ -122,10 +122,10 @@
`{:at a :rate r}`, meaning symbol frame `p` is frame `r·(p − a)` of `id`.
Identity for `nil`, which is a node sitting directly in the symbol.
THE FRAME SPACE A COMMAND IS GIVEN ITS COORDINATE IN. A cel's parent is its
lane, so a lane command composing this for the lane reads lane time; a node
with no parent reads the symbol's own frames. One rule either way, so a caller
holding a node does not have to ask what it is sitting in.
THE FRAME SPACE A COMMAND IS GIVEN ITS COORDINATE IN. A direct child reads
the symbol's own frames. A node grouped beneath another composes through that
parent chain. One rule either way, so a caller holding a node does not have to
ask what it is sitting in or how the timeline happens to draw the symbol.
Refuses floors and loops rather than pretend an affine map preserves them:
through either, one frame of the symbol is not one frame of `id` and a command
@ -141,8 +141,8 @@
(recur (:parent n) (conj seen id) (conj chain n)))))))
(defn lane?
"Whether symbol `sym` is DRAWN as a lane: its clips as blocks on one row,
following one another in time and claiming it from each other.
"Whether symbol `sym` is EDITED AND DRAWN as a lane: its clips as blocks on
one row, following one another in time and claiming it from each other.
A DISPLAY HINT AND NOT A TYPE. Nothing in evaluation reads it, `problems` does
not check it, and a symbol carrying it behaves identically on the stage — it
@ -153,8 +153,8 @@
from \"the clips do not currently overlap\" because a symbol must not stop being
a lane the moment something overlaps — that is when the rules are needed.
The only things allowed to read it are the timeline and `span/finish`'s
overlap check. See `docs/lane-is-a-view-plan.md`."
Editing and presentation may read it; evaluation may not. See
`docs/lane-is-a-view-plan.md`."
[sym]
(= :lane (:display sym)))

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

@ -728,36 +728,19 @@
(rf/reg-event-db
::drop-clip
;; A CLIP BODY DRAGGED ONTO A ROW. Within its own symbol this is `span/adopt`,
;; which claims the time it lands on — a drop onto occupied frames has already
;; said it means to. Onto a row leading into ANOTHER symbol it is that, after
;; `nest/move-node` carries the clip across keeping its world transform; the two
;; commit as one transaction, so it is still one undo step.
(fn [db [_ [_ from-sid id from-path] target-path frame]]
;; A clip body is already materialized, so its whole drop is: resolve the
;; destination, then transfer it. `span/transfer` asks the destination whether
;; it claims time; this event does not know or care whether that is a lane.
(fn [db [_ [_ from-sid id _] target frame]]
(let [{document :clip st :store} (store/entry (:clip/current db))
open (get-in db [:ui :open])
into (nest/inside document st open (vec target-path) frame)
crossing? (not= from-sid (:sid into))
carried (when (and (:sid into) crossing?)
(nest/move-node document st open (vec from-path) (vec target-path) frame))
doc (if crossing? (:clip carried) document)
landed-id (if crossing? (:id carried) id)
result (cond
(nil? (:sid into))
{:refused "what you are dropping into is not on screen at this frame"}
(not (integer? (:frame into)))
{:refused "the drop is not on one frame of that symbol"}
(and crossing? (:refused carried)) carried
:else (span/adopt doc (:sid into) landed-id (:frame into)
where (drop-destination db document st frame target)
result (when-not (:refused where)
(span/transfer document from-sid id (:sid where) (:at where)
{:extent :grow-symbol
:remainder-id (random-uuid)}))]
(if-let [why (:refused result)]
(if-let [why (or (:refused where) (:refused result))]
(update db :project merge {:status why})
(-> db
(edit/transaction (constantly (:clip result)))
(assoc-in [:ui :selection]
[:node (:sid into) landed-id
(conj (vec target-path) landed-id)]))))))
(landed db where id result)))))
;; ---------------------------------------------------------------------------
;; moving rows between symbols
@ -769,48 +752,6 @@
(defn- refused [db why]
(update db :project merge {:status (str "can't: " why)}))
(rf/reg-event-db
::adopt-in-lane
;; Plain body-drag is temporal. The destination row names either an instance
;; of an explicit lane symbol, or the open lane symbol itself. Moving between
;; two lane symbols transfers the clip before `span/adopt` claims its new time;
;; Shift-drag remains the separate structural `::move-node` operation below.
(fn [db [_ [_ from-sid id _] [_ target-sid target-id target-path :as target]
frame]]
(let [{document :clip st :store} (store/entry (:clip/current db))
open (get-in db [:ui :open])
target-node (get-in document [:symbols target-sid :nodes target-id])
dest-sid (if target-id (node/source target-node) target-sid)
dest (clip/symbol document dest-sid)
local-frame (if (seq target-path)
(:frame (nest/inside document st open target-path frame))
(:frame (nest/inside document st open [] frame)))
n (get-in document [:symbols from-sid :nodes id])
seeded (when (and n dest-sid)
(if (= from-sid dest-sid)
document
(-> document
(update-in [:symbols from-sid :nodes] dissoc id)
(assoc-in [:symbols dest-sid :nodes id]
(dissoc n :parent)))))
result (cond
(nil? n) {:refused "select a clip to move"}
(not (symbol/lane? dest)) {:refused "drop onto an explicit lane"}
(and (not= from-sid dest-sid)
(contains? (get-in document [:symbols dest-sid :nodes]) id))
{:refused "the destination already has a clip with that ID"}
(not (integer? local-frame))
{:refused "the drop is not on one frame of this lane"}
:else (span/adopt seeded dest-sid id local-frame
{:extent :grow-symbol
:remainder-id (random-uuid)}))]
(if-let [why (:refused result)]
(refused db why)
(-> db
(edit/transaction (constantly (:clip result)))
(assoc-in [:ui :selection]
[:node dest-sid id (conj (vec target-path) id)]))))))
(rf/reg-event-db
::move-node
(fn [db [_ from to]]

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

@ -686,8 +686,8 @@
(not= (:select under) (:selection drag)))
under)
[target-el target] (when (and drag (not shift?)) (lane-under e))
crossing? (and target (not= target (:source-lane drag)))
target-frame (when crossing?
landing? (some? target)
target-frame (when landing?
(max 0 (- (frame-at-element e frames target-el)
(:grab drag))))]
(when (and drag hint)
@ -706,7 +706,7 @@
(swap! sliding #(-> % (assoc :nest nest)
(dissoc :target-lane :target-frame)))
(rf/dispatch [::ui/sliding nil]))
crossing?
landing?
(do
(swap! sliding #(-> % (assoc :target-lane target
:target-frame target-frame)
@ -735,7 +735,7 @@
(nth (:select nest) 3)]))
(and commit? target-lane drag)
(do (rf/dispatch [::ui/sliding nil])
(rf/dispatch [::ui/adopt-in-lane (:selection drag)
(rf/dispatch [::ui/drop-clip (:selection drag)
target-lane target-frame]))
commit?
;; A press that moved nothing is a click, and a drag
@ -760,7 +760,6 @@
:on-click actual-select
:drag (when drag
(assoc drag
:source-lane select
:grab (- (frame-at-element e frames track)
(:in drag))))
:ripple? (and (= :out gesture-kind) (.-shiftKey e))
@ -804,7 +803,7 @@
(.stopPropagation e)
(if-let [from (drag/row-selection)]
(do (drag/done!)
(rf/dispatch [::ui/adopt-in-lane from select
(rf/dispatch [::ui/drop-clip from select
(frame-at e frames)]))
(drag/land! (frame-at e frames) nil select))))}
;; Clipped to the ruler: an instance longer than the room left in its

47
frontend/test/arthur/domain/sequence_test.cljs
View file

@ -394,6 +394,53 @@
(mapv node/placed-span (symbol/children (get-in after [:symbols :main :nodes]))))
"it is simply placed, on screen with what was already there"))))
(deftest repeated-symbol-drops-keep-the-symbols-natural-duration
(let [empty-lane (assoc-in (document) [:symbols :main]
{:id :main :frames 40 :display :lane :nodes {}})
once (:clip (span/place-symbol empty-lane nil :main :one :wave 0
{:extent :grow-symbol :remainder-id :r1}))
twice (:clip (span/place-symbol once nil :main :two :wave 10
{:extent :grow-symbol :remainder-id :r2}))
thrice (:clip (span/place-symbol twice nil :main :three :wave 20
{:extent :grow-symbol :remainder-id :r3}))]
(is (= [[:one [0 10]] [:two [10 20]] [:three [20 30]]]
(mapv (juxt :id node/placed-span)
(symbol/children (get-in thrice [:symbols :main :nodes]))))
"materializing the same source repeatedly does not collapse later instances")
(is (every? #(= [0 10] (:span %))
(symbol/children (get-in thrice [:symbols :main :nodes]))))
(let [resolve (clip/resolver thrice :main nil pal/index-of nil)]
(doseq [[id at] [[:one 0] [:two 10] [:three 20]]]
(is (= [0 300 600 900]
(mapv (fn [f]
(let [op (first (filter #(= [id :mark] (:node %))
(resolve (+ at f))))]
(js/Math.round (:cx op))))
[0 3 6 9]))
(str id " gets its own complete source clock"))))
(is (empty? (clip/problems thrice)))))
(deftest transfer-is-one-placement-rule-with-two-destination-modes
(let [doc (document)
moved (:clip (span/transfer doc :main :insert :main 2
{:extent :grow-symbol :remainder-id :rest}))
clips (symbol/children (get-in moved [:symbols :main :nodes]))]
(is (= [[0 2] [2 6] [6 8]] (mapv node/placed-span clips))
"moving within a lane claims the landing interval from both neighbours")
(is (= :insert (:id (second clips))))
(is (empty? (symbol/overlaps (get-in moved [:symbols :main]))))
;; The identical transfer into an ordinary symbol simply composites.
(let [ordinary (assoc-in doc [:symbols :other]
{:id :other :frames 12
:nodes {:existing (cel :existing :drawing-a 0 4 0)}})
free (:clip (span/transfer ordinary :main :b :other 1
{:extent :grow-symbol :remainder-id :rest}))]
(is (= #{:existing :b} (set (keys (get-in free [:symbols :other :nodes])))))
(is (= 1 (count (symbol/overlaps (get-in free [:symbols :other]))))
"overlap is ordinary composition outside lane mode")
(is (nil? (get-in free [:symbols :main :nodes :b])))
(is (empty? (clip/problems free))))))
(deftest an-existing-clip-can-be-moved-and-claim-where-it-lands
(let [doc (assoc-in (document) [:symbols :main :nodes :badge]
{:id :badge :kind :instance :z "z"