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

Make lanes explicit symbol views

Browse source
This commit is contained in:
Your Name 2026-10-01 19:40:53 -04:00
parent fb38990090
commit e459307a4a
22 changed files with 2183 additions and 2330 deletions
Download patch file Download diff file Expand all files Collapse all files

24
frontend/src/arthur/domain/clip.cljs
View file

@ -149,20 +149,13 @@
which is long enough to key something into and short enough to scrub by hand."
120)
(def lane-node
"The lane every symbol is born with.
EVERY SYMBOL HAS AT LEAST ONE LANE, because a lane is the only place
temporal content goes and a symbol with none has nowhere to drop a thing —
which made the first drop into any symbol a special case that had to invent
a lane before it could do what the second drop does. An empty lane is a true
statement about a symbol nobody has put anything in yet. The id is a keyword
rather than a uuid because this namespace is pure, and `:lane` reads in a
path; commands that add FURTHER lanes bring their own uuids."
{:id :lane :name "lane" :kind :group :layout :sequence :z "z-lane"})
(defn blank
"A new, empty document: one symbol, holding one empty lane.
"A new, empty document: one symbol, and nothing in it.
A SYMBOL IS BORN EMPTY. It used to be born holding a lane, because a lane was
the only place temporal content could go; now the symbol itself is the
container — see `symbol/children` — so there is nothing to invent and the
first drop into a symbol is the same operation as the second.
The tracking maps are ABSENT rather than empty, because `leaf/leaves` writes no
leaf for an empty one and so cannot bring it back: a blank document that opened
@ -174,8 +167,7 @@
{:name "untitled"
:fps 30
:width 320 :height 200
:symbols {:main {:id :main :fps 30 :frames blank-frames
:nodes {:lane lane-node}}}})
:symbols {:main {:id :main :fps 30 :frames blank-frames :nodes {}}}})
(defn- transform-op
"Put a symbol's already resolved mark into its instance's parent space. Its
@ -421,7 +413,7 @@
clip
(-> clip
(assoc-in [:symbols sid] {:id sid :name (name sid) :fps (fps clip host)
:frames (- end frame) :nodes {:lane lane-node}})
:frames (- end frame) :nodes {}})
(place-symbol nil host sid frame uuid nil)))))
(defn free-id

494
frontend/src/arthur/domain/lane.cljs
View file

@ -1,494 +0,0 @@
(ns arthur.domain.lane
"The commands that need a SEQUENCE: make a lane, place symbol clips in it,
change how long they are exposed, empty part of it, and decide which held
drawing clips share content.
WHAT A LANE IS lives in `arthur.domain.symbol`, beside the other rules about a
node map: a group with `:layout :sequence`, whose children are non-overlapping
visual symbol clips. This namespace only changes them.
WHAT IS NOT HERE: split, trim and move. Each of those is one write to one
node's span or position, which is a fact every node has, so they live in
`arthur.domain.span` and work on a symbol placed straight into a shot as
readily as on a cel. What stays here is everything that cannot be said about
one node alone — a ripple needs later siblings, a gap needs a row to be a hole
in, and appending needs to know where the row stops.
EVERY COMMAND IS ONE STEP AND ALL OF IT. Each returns `{:clip :selection}` or
`{:refused reason}` — never a half-applied edit, and never a document that
`clip/problems` would reject. A command that cannot say what the person meant
refuses and says why, rather than picking for them: the overflow policy is a
caller's `:extent`, and decoupling shared content is its own command instead
of something an ordinary edit does silently.
IDS FOR CELS COME FROM THE CALLER, because a cel's identity is
a uuid and this namespace is pure. Ids for new CONTENT are derived from the
drawing being copied — `clip/free-id` is pure too, and `drawing-a-2` says what
it came from in a way `symbol-7` does not."
(:require [arthur.domain.bring :as bring]
[arthur.domain.clip :as clip]
[arthur.domain.node :as node]
[arthur.domain.span :as span]
[arthur.domain.symbol :as symbol]))
(defn extend-hold
"Change one held cel's duration by `delta` lane frames and ripple its
later siblings. Lane channels, cel channels and source clocks stay put.
Returns {:clip :selection} or {:refused :required-frames?}; never partially edits."
[clip sid id delta {:keys [extent] :or {extent :keep}}]
(let [nodes (get-in clip [:symbols sid :nodes])
n (get nodes id)
lane (get nodes (:parent n))
rate (:rate (node/time-of n))
span (:span n)
m (when lane (symbol/frame-map nodes (:id lane)))
;; The LANE's own shape, not the whole symbol's: refusing a cel
;; edit over some unrelated defect elsewhere in the symbol would be
;; this command answering for a part of the document it never touches.
broken (first (symbol/lane-problems nodes))]
(cond
(not (node/lane? lane)) {:refused "select a cel in a lane"}
broken {:refused broken}
(not (and (integer? delta) (not (zero? delta)))) {:refused "hold change must be a nonzero whole number of lane frames"}
(not (zero? (:speed (node/playback-of n)))) {:refused "hold length applies to a held drawing"}
(nil? m) {:refused "cel timing through a stepped or looping lane is not supported"}
(<= (+ (second span) (* rate delta)) (first span)) {:refused "a drawing must keep a positive cel"}
:else
(let [[_ boundary] (node/placed-span n)
later (filter #(>= (first (node/placed-span %)) boundary)
(symbol/lane-clips nodes (:id lane)))
nodes (assoc-in nodes [id :span 1] (+ (second span) (* rate delta)))
nodes (reduce (fn [ns sibling]
(update-in ns [(:id sibling) :time :at] (fnil + 0) delta))
nodes later)]
(span/finish clip sid nodes id extent)))))
(defn resize-out
"Put cel `id`'s right edge at lane frame `to`.
Without `ripple?`, growing the cel consumes the starts of the cels it reaches:
wholly covered cels disappear and the last partially covered one is trimmed.
Shrinking leaves a gap. With `ripple?`, every cel beginning at or after the
old edge moves by the same delta, in either direction, so their contents are
preserved. A lane never contains an overlap in either mode."
[clip sid id to {:keys [extent ripple?] :or {extent :keep ripple? false}}]
(let [nodes (get-in clip [:symbols sid :nodes])
n (get nodes id)
lane (get nodes (:parent n))
[lo old-out] (when n (node/placed-span n))
members (when (node/lane? lane) (symbol/lane-clips nodes (:id lane)))
later (when members
(remove #(= id (:id %))
(filter #(>= (first (node/placed-span %)) old-out) members)))
broken (first (symbol/lane-problems nodes))]
(cond
(not (node/lane? lane)) {:refused "select a cel in a lane"}
broken {:refused broken}
(not (integer? to)) {:refused "a cel edge goes to a whole lane frame"}
(not (< lo to)) {:refused "a drawing must keep at least one frame"}
(= to old-out) {:clip clip :selection id}
:else
(let [delta (- to old-out)
resized (assoc nodes id (span/edged n :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) (span/edged sibling :in to)))))
resized later)
resized))]
(span/finish clip sid changed id extent)))))
(defn resize-in
"Put cel `id`'s left edge at lane frame `to`. Shrinking leaves a gap;
growing left consumes earlier cels symmetrically with `resize-out`."
[clip sid id to]
(let [nodes (get-in clip [:symbols sid :nodes])
n (get nodes id)
lane (get nodes (:parent n))
[old-in hi] (when n (node/placed-span n))
earlier (when (node/lane? lane)
(remove #(= id (:id %))
(filter #(<= (second (node/placed-span %)) old-in)
(symbol/lane-clips nodes (:id lane)))))
broken (first (symbol/lane-problems nodes))]
(cond
(not (node/lane? lane)) {:refused "select a cel in a lane"}
broken {:refused broken}
(not (integer? to)) {:refused "a cel edge goes to a whole lane frame"}
(not (< to hi)) {:refused "a drawing must keep at least one frame"}
(neg? to) {:refused "a cel cannot begin before the lane"}
(= to old-in) {:clip clip :selection id}
:else
(let [resized (assoc nodes id (span/edged n :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) (span/edged sibling :out to)))))
resized earlier)
resized)]
(span/finish clip sid changed id :keep)))))
(defn roll
"Move the shared boundary between adjacent cels `left-id` and `right-id`.
This is deliberately only the composition of the two ordinary edge edits."
[clip sid left-id right-id to]
(let [nodes (get-in clip [:symbols sid :nodes])
left (get nodes left-id)
right (get nodes right-id)
lane (get nodes (:parent left))
[llo lhi] (when left (node/placed-span left))
[rlo rhi] (when right (node/placed-span right))]
(cond
(or (not (node/lane? lane)) (not= (:parent left) (:parent right)))
{:refused "a rolling edit needs two cels in one lane"}
(not= lhi rlo) {:refused "a rolling edit needs one shared boundary"}
(not (integer? to)) {:refused "a cel edge goes to a whole lane frame"}
(not (< llo to rhi)) {:refused "both drawings must keep at least one frame"}
:else
(let [left-result (resize-out clip sid left-id to {})]
(if (:refused left-result)
left-result
(resize-in (:clip left-result) sid right-id to))))))
(defn blank
"Clear lane frames `[a b)` of lane `lane-id`, leaving a GAP.
A gap is not a drawing. Nothing is invented to cover those frames and nothing
closes the hole — the cels after it stay where they are, because
emptying frames and re-timing a performance are different intentions.
What it does to each cel it meets is `span/edged`, applied three ways: one wholly
inside is removed, one overlapping an end is trimmed to it, and the one that
spans the whole range is split, which is the only case that needs `id`. Their
drawings stay in the library — a lane does not own its content, and a drawing
whose last cel is gone is still a drawing somebody made."
[clip sid lane-id [a b] {:keys [id]}]
(let [nodes (get-in clip [:symbols sid :nodes])
lane (get nodes lane-id)
members (when (node/lane? lane) (symbol/lane-clips nodes lane-id))
spanning (when members
(first (filter #(let [[lo hi] (node/placed-span %)] (and (< lo a) (> hi b)))
members)))]
(cond
(not (node/lane? lane)) {:refused "select a lane"}
(not (and (integer? a) (integer? b) (< a b)))
{:refused "a range to blank is whole lane frames, and not empty"}
(and spanning (or (nil? id) (contains? nodes id)))
{:refused "blanking inside one cel splits it, which needs a free ID for the remainder"}
:else
(let [nodes (reduce
(fn [ns n]
(let [[lo hi] (node/placed-span n)]
(cond
(or (<= hi a) (>= lo b)) ns
(and (< lo a) (> hi b))
(-> ns
(assoc (:id n) (span/edged n :out a))
(assoc id (assoc (span/edged n :in b) :id id :z (str "a-" id))))
(and (>= lo a) (<= hi b)) (dissoc ns (:id n))
(< lo a) (assoc ns (:id n) (span/edged n :out a))
:else (assoc ns (:id n) (span/edged n :in b)))))
nodes members)]
(span/finish clip sid nodes (or (when spanning id) lane-id) :keep)))))
(defn add-lane [clip sid id]
(let [nodes (get-in clip [:symbols sid :nodes])
front (last (sort (keep (fn [[_ n]] (when (nil? (:parent n)) (:z n))) nodes)))]
(if (or (nil? (clip/symbol clip sid)) (get nodes id))
{:refused "the symbol is missing or the lane ID is already used"}
{:clip (assoc-in clip [:symbols sid :nodes id]
{:id id :name "lane" :kind :group :layout :sequence
:z (symbol/z-between front nil)})
:selection id})))
(defn- holds-other?
"Whether `lane-id` already holds clips that are not of `kind`.
A lane holds picture or sound and not both, and the check belongs HERE
rather than only in validation: placement claims time, so a picture dropped
on a lane of sound would not be caught as a mixture — `blank` would have
deleted the sound to make room for it first, and the document would be
valid and the sound gone."
[nodes lane-id kind]
(boolean (some #(not= kind (:kind %)) (symbol/lane-clips nodes lane-id))))
(defn place-symbol
"Place arbitrary symbol `source-id` as a naturally playing clip in a lane.
The new clip claims its interval: existing clips under that interval are
trimmed, removed, or split by `blank`, so the lane remains a partition rather
than storing an overlap. This is the generic operation behind dropping a
library symbol into a lane; one-frame held drawing creation remains a policy
of `append-drawing`/`overwrite-drawing`, not a different lane type."
[clip store sid lane-id id source-id at
{:keys [extent point remainder-id] :or {extent :keep}}]
(let [nodes (get-in clip [:symbols sid :nodes])
lane (get nodes lane-id)
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))))]
(cond
(not (node/lane? lane)) {:refused "select a lane"}
(holds-other? nodes lane-id :instance)
{:refused "that lane holds sound; a lane holds picture or sound, not both"}
(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 lane 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 [cleared (blank clip sid lane-id [at (+ at duration)]
{:id remainder-id})]
(if (:refused cleared)
cleared
(let [nodes (assoc (get-in (:clip cleared) [:symbols sid :nodes]) id
(-> n
(assoc :parent lane-id)
(assoc-in [:time :at] at)))]
(span/finish (:clip cleared) sid nodes id extent)))))))
(defn adopt
"Move an existing clip — a symbol instance or a sound — into `lane-id` at
lane frame `at`. Its source, span, transforms, corrections, and identity come
with it; the destination interval is claimed with the same overwrite trimming
as a pool drop. What a lane may not do is mix the two kinds, which
`symbol/lane-problems` is the judge of and `finish` enforces."
[clip sid lane-id id at {:keys [extent remainder-id] :or {extent :keep}}]
(let [nodes (get-in clip [:symbols sid :nodes])
lane (get nodes lane-id)
n (get nodes id)
[lo hi] (when n (node/placed-span n))
duration (when (and lo hi) (- hi lo))]
(cond
(not (node/lane? lane)) {:refused "select a lane"}
(not (contains? #{:instance :audio} (:kind n)))
{:refused "only a symbol or sound clip goes in a lane"}
(holds-other? nodes lane-id (:kind n))
{:refused "a lane holds picture or sound, not both"}
(= lane-id (:parent n)) {:refused "this clip is already in that lane"}
(not (and (integer? at) (not (neg? at))))
{:refused "a position is a nonnegative whole lane 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 [cleared (blank clip sid lane-id [at (+ at duration)] {:id remainder-id})]
(if (:refused cleared)
cleared
(let [moved (-> n
(assoc :parent lane-id)
(update-in [:time :at] (fnil + 0) (- at lo)))
nodes (assoc (get-in (:clip cleared) [:symbols sid :nodes]) id moved)]
(span/finish (:clip cleared) sid nodes id extent)))))))
;; ---------------------------------------------------------------------------
;; putting drawings in a lane
(defn- held
"A one-frame held cel of `drawing-id`, starting at lane frame `at`.
Held rather than playing, and one frame rather than the length of what it
places: a cel's duration is the lane's business — `extend-hold` is how
it changes — and reading it off the content would make placing a ten-frame
animation and holding its first drawing the same gesture."
[id lane-id drawing-id at]
{:id id :kind :instance :parent lane-id :z (str "a-" id)
:span [0 1] :time {:at at :rate 1}
:source {:symbol drawing-id} :playback {:in 0 :speed 0 :end :stop}})
(defn lane-frame
"Symbol frame `f` as a frame of lane `lane-id`'s OWN time, or nil through a
stepped or looping lane, where one frame of the symbol is not one frame of the
lane and there is no single answer to give a command."
[clip sid lane-id f]
(when-let [{:keys [at rate]} (symbol/frame-map (get-in clip [:symbols sid :nodes]) lane-id)]
(* rate (- f at))))
(defn- lane-end
"Where lane `lane-id`'s occupied frames stop, in its own time."
[nodes lane-id]
(apply max 0 (map #(second (node/placed-span %))
(symbol/lane-clips nodes lane-id))))
(defn- place
"Put a held cel of `drawing-id` into `lane-id` at lane frame `at`, and
RIPPLE: everything starting at or after it moves later by its duration.
There is one placement function and `:end` is a position like any other, so
appending is not a different operation from inserting — the end is just where
nothing has to move. Overwriting is the other policy and is NOT this: taking
frames away from the cel already there is trimming, which is its own
command and not something placing a drawing should do on the quiet.
`:frame` in the result is where it landed, in the open symbol's time, for a
caller that wants to look at what it just made."
[clip sid lane-id id drawing-id at extent ripple?]
(let [nodes (get-in clip [:symbols sid :nodes])
at (if (= :end at) (lane-end nodes lane-id) at)
n (held id lane-id drawing-id at)
[lo hi] (node/placed-span n)
later (when ripple?
(filter #(>= (first (node/placed-span %)) lo)
(symbol/lane-clips nodes lane-id)))
nodes (reduce (fn [ns sibling]
(update-in ns [(:id sibling) :time :at] (fnil + 0) (- hi lo)))
(assoc nodes id n) later)
result (span/finish clip sid nodes id extent)
m (symbol/frame-map nodes lane-id)]
(cond-> result
(:clip result) (assoc :frame (+ (:at m) (/ at (:rate m)))))))
(defn- placeable
"Why a held cel cannot go into `lane-id` at `at`, or nil."
[clip sid lane-id id at]
(let [nodes (get-in clip [:symbols sid :nodes])
lane (get nodes lane-id)
;; INSIDE a cel is not a position for another one. Splitting that
;; cel is what makes it two, and doing it here would be one command
;; quietly performing two: the caller asks for `split` and then places.
inside (when (number? at)
(some (fn [n] (let [[lo hi] (node/placed-span n)]
(when (< lo at hi) n)))
(symbol/lane-clips nodes lane-id)))]
(cond
(not (node/lane? lane)) "select a lane"
(contains? nodes id) "the new cel ID is already used"
(not (or (= :end at) (and (integer? at) (not (neg? at)))))
"a position is :end or a whole lane frame"
inside (str "frame " at " is inside a cel; split it first")
(nil? (symbol/frame-map nodes lane-id)) "drawing creation through a stepped or looping lane is not supported"
:else (first (symbol/lane-problems nodes)))))
(defn append-drawing
"Append fresh empty content and a held cel of it. IDs come from the
caller so a command is deterministic and replayable.
Fresh content, not a blank range: a lane with no cel over a frame shows
nothing there already, and a drawing nobody has drawn in is a different thing
from a gap."
[clip sid lane-id id drawing-id {:keys [at extent] :or {extent :keep at :end}}]
(if-let [why (or (placeable clip sid lane-id id at)
(when (clip/symbol clip drawing-id) "the new drawing ID is already used"))]
{:refused why}
(place (assoc-in clip [:symbols drawing-id]
{:id drawing-id :name (name drawing-id) :fps (clip/fps clip sid) :frames 1 :nodes {}})
sid lane-id id drawing-id at extent true)))
(defn reuse-drawing
"Append a held cel of content the document ALREADY has, so the same
drawing is exposed twice and editing it changes both cels.
This is the command `make-unique` is the undo of, and the reason they are two
commands: reuse is a decision to share, and sharing is not something to
discover later when an edit turns up somewhere else."
[clip sid lane-id id drawing-id {:keys [at extent] :or {extent :keep at :end}}]
(if-let [why (or (placeable clip sid lane-id id at)
(when-not (clip/symbol clip drawing-id) "there is no such drawing to reuse")
;; Placing something that contains this symbol would close a
;; loop, and a lane is no different from any other placement.
(when (clip/contains-symbol? clip drawing-id sid)
"a symbol cannot go inside itself"))]
{:refused why}
(place clip sid lane-id id drawing-id at extent true)))
(defn- copied
"A copy of symbol `from`, as `{:clip :id}`.
SHALLOW by default: its own nodes and channels are copied, and its references
to other symbols are kept, so a head built out of reusable eyes still uses
those eyes. `deep?` copies everything it places as well, with new ids
throughout, for a drawing that must share nothing — the distinction the
shallow copy cannot make on its own, and a promise of independence that only
the deep one keeps."
[clip from deep?]
(if deep?
(let [{c :clip ids :ids} (bring/symbols clip clip [from] {})]
{:clip c :id (ids from)})
(let [id (clip/free-id (:symbols clip) from)]
{:clip (assoc-in clip [:symbols id] (assoc (clip/symbol clip from) :id id))
:id id})))
(defn duplicate-drawing
"Append a held cel of a COPY of what cel `id` places, for when
the drawing on screen is the starting point for the next one.
The copy is of the content only. The new cel is a plain one-frame hold
rather than a copy of `id`'s own transform or corrections: those belong to
that cel, and carrying them over would make duplicating a drawing quietly
duplicate the treatment of one use of it."
[clip sid id new-id {:keys [at extent deep?] :or {extent :keep at :end}}]
(let [n (get-in clip [:symbols sid :nodes id])
from (node/source n)]
(if-let [why (or (when-not from "select a cel to duplicate")
(when-not (clip/symbol clip from) "the drawing it places is missing")
(placeable clip sid (:parent n) new-id at))]
{:refused why}
(let [{c :clip copy :id} (copied clip from deep?)]
(place c sid (:parent n) new-id copy at extent true)))))
(defn overwrite-drawing
"Put a fresh one-frame drawing at lane frame `at`, replacing whatever was
there and leaving every other cel where it was.
This is `blank` and placement composed in ONE command and therefore one undo
step. `remainder-id` is used only when clearing the frame cuts one cel into
two; ids still come from the caller because this namespace is pure."
[clip sid lane-id id drawing-id at {:keys [extent remainder-id]
:or {extent :keep}}]
(let [nodes (get-in clip [:symbols sid :nodes])]
(if-let [why (cond
(not (and (integer? at) (not (neg? at))))
"a position is a nonnegative whole lane frame"
(contains? nodes id) "the new cel ID is already used"
(or (= id remainder-id) (contains? nodes remainder-id))
"the remainder cel needs a free ID different from the new cel"
(clip/symbol clip drawing-id) "the new drawing ID is already used"
(nil? (symbol/frame-map nodes lane-id))
"drawing creation through a stepped or looping lane is not supported")]
{:refused why}
(let [cleared (blank clip sid lane-id [at (inc at)] {:id remainder-id})]
(if (:refused cleared)
cleared
(place (assoc-in (:clip cleared) [:symbols drawing-id]
{:id drawing-id :name (name drawing-id) :fps (clip/fps clip sid) :frames 1 :nodes {}})
sid lane-id id drawing-id at extent false))))))
(defn make-unique
"Point cel `id` at a private copy of its content, leaving every other
cel of that drawing sharing the original.
Refused when nothing else uses it: a drawing with one cel is already
unique, and answering with a silent copy would leave a second identical symbol
in the library for no reason a person could see."
[clip sid id {:keys [deep?]}]
(let [n (get-in clip [:symbols sid :nodes id])
from (node/source n)
elsewhere (for [[osid osym] (:symbols clip)
[oid on] (:nodes osym)
:when (and (= from (node/source on)) (not= [sid id] [osid oid]))]
[osid oid])]
(if-let [why (or (when-not from "select a cel to make unique")
(when-not (clip/symbol clip from) "the drawing it places is missing")
(when (empty? elsewhere) "nothing else uses this drawing"))]
{:refused why}
(let [{c :clip copy :id} (copied clip from deep?)
c (assoc-in c [:symbols sid :nodes id :source :symbol] copy)
ps (clip/problems c)]
(if (seq ps) {:refused (first ps)} {:clip c :selection id})))))

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

@ -144,7 +144,7 @@
;; disagree with itself about; `clip` puts it back.
(for [[sid sym] (:symbols clip)]
{(at "symbol" (segment sid))
(select-keys sym [:name :frames :fps :width :height :palette])})
(select-keys sym [:name :frames :fps :width :height :palette :display])})
(for [[sid sym] (:symbols clip)
[id n] (:nodes sym)]
{(at "symbol" (segment sid) "node" (segment id))

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

@ -19,7 +19,6 @@
matrix becomes a `:pinv`, Blender's parent-inverse, and the time a new `:at`
and `:rate`. Its channels, keys and span are untouched."
(:require [arthur.domain.clip :as clip]
[arthur.domain.lane :as lane]
[arthur.domain.node :as node]
[arthur.domain.palette :as pal]
[arthur.domain.span :as span]
@ -73,7 +72,7 @@
inner (:symbol shown)
lf (if shown (:frame shown) local)]
(if (and m (number? local)
;; A lane over a gap has no inside to be in.
;; A clip over a gap has no inside to be in.
(or (not inst?) shown)
(or (nil? inner) (< -1 lf (clip/frames clip inner))))
{:sid inner :frame (js/Math.floor lf)
@ -284,8 +283,8 @@
The one that surprises: BOTH have to be on screen at this frame, because the
move keeps the picture and there is no common frame to keep it at otherwise.
Two clips in one lane never overlap, so nesting one into another there can
never be done — it is a thing to do between lanes, with the playhead
Two clips of one lane never overlap, so nesting one into another there can
never be done — it is a thing to do between symbols, with the playhead
somewhere both of them are showing.
The deeper refusals — generated parts, a stencil parted from what it clips —
@ -335,8 +334,8 @@
only a move that keeps the PICTURE needs a frame, for the matrix."
[clip sid path]
(let [;; Structurally, a row leads into a symbol only where it names one:
;; a cel does, and the lane holding it does not, so the walk
;; stops at a lane rather than picking the drawing showing now — which
;; a clip does, and a group holding one does not, so the walk stops at
;; the group rather than picking the drawing showing now — which
;; would make where a row lives depend on the playhead.
only (fn [sid id]
(when sid (node/source (get-in clip [:symbols sid :nodes id]))))
@ -394,8 +393,10 @@
(defn resize-out
"Move the right edge of the node at `path` by `df` frames of `open`.
Lane cels use the lane's collision/ripple rules; ordinary clips, including
audio, resize independently."
One command either way: in a symbol drawn as a lane `span/resize-out` claims
the time it grows into, and in a composition it is one write to one span. The
mode says which, and nothing here has to ask."
[clip open path df ripple?]
(let [here (down clip open (pop path))
sid (:sid here)
@ -409,12 +410,10 @@
(let [chain (map #(get nodes %) (reverse (rest (symbol/lineage nodes id))))
d (* df (:rate (reduce node/then-time (:time here) (map node/time-of chain))))
to (+ (second (node/placed-span n)) d)]
(if (node/lane? (get nodes (:parent n)))
(lane/resize-out clip sid id to {:ripple? ripple? :extent :grow-symbol})
(span/resize-out clip sid id to))))))
(span/resize-out clip sid id to {:ripple? ripple? :extent :grow-symbol})))))
(defn resize-in
"Move a lane cel's left edge by `df` frames of `open`."
"Move the left edge of the node at `path` by `df` frames of `open`."
[clip open path df]
(let [here (down clip open (pop path))
sid (:sid here)
@ -424,13 +423,11 @@
(cond
(nil? n) {:refused "nothing to resize"}
(nil? (:time here)) {:refused "a looping instance is in the way"}
(not (node/lane? (get nodes (:parent n))))
{:refused "only a lane cel has a collision-free left edge"}
:else
(let [chain (map #(get nodes %) (reverse (rest (symbol/lineage nodes id))))
d (* df (:rate (reduce node/then-time (:time here) (map node/time-of chain))))
to (+ (first (node/placed-span n)) d)]
(lane/resize-in clip sid id to)))))
(span/resize-in clip sid id to)))))
(defn roll
"Move the shared boundary at `right-path` and the adjacent `left-path`."
@ -443,13 +440,13 @@
right (get nodes right-id)]
(cond
(or (not= (pop left-path) (pop right-path)) (nil? right))
{:refused "a rolling edit needs adjacent clips in one lane"}
{:refused "a rolling edit needs adjacent clips in one sequence"}
(nil? (:time here)) {:refused "a looping instance is in the way"}
:else
(let [chain (map #(get nodes %) (reverse (rest (symbol/lineage nodes right-id))))
d (* df (:rate (reduce node/then-time (:time here) (map node/time-of chain))))
to (+ (first (node/placed-span right)) d)]
(lane/roll clip sid left-id right-id to)))))
(span/roll clip sid left-id right-id to)))))
(defn restack
"Put the node at row path `from` just in front of the one at `to` when

14
frontend/src/arthur/domain/node.cljs
View file

@ -244,16 +244,6 @@
(when (and (<= 0 frame) (< frame length))
{:symbol sid :frame frame})))))
(defn lane?
"Is this group a LANE — a succession of cels rather than a composition?
`:layout :sequence` is the field because it names the RULE: children follow
one another and may not overlap. A group carrying it is called a lane, which
is the one place two words are kept for one thing, and they are kept apart on
purpose — the layout says what the rule is, the noun says what the thing is."
[n]
(and (= :group (:kind n)) (= :sequence (:layout n))))
(defn finite-number? [v] (and (number? v) (js/Number.isFinite v)))
(defn local-frame
@ -415,8 +405,8 @@
(finite-number? speed) (<= 0 speed)
(#{:stop :hold :loop} end)))))
(conj "playback needs a nonnegative finite :in and :speed, and :end :stop, :hold or :loop")
(and (:layout n) (not (lane? n)))
(conj ":layout :sequence belongs to a group")
(:layout n)
(conj ":layout is not a node field — a lane is how the timeline DRAWS a symbol, not a thing in the document")
(and (= k :audio) (not (some (:source n) [:footage :sound])))
(conj "an audio node needs a :source :footage or :sound")
(and (some? (get-in n [:time :rate]))

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

@ -1,28 +1,51 @@
(ns arthur.domain.span
"The commands over ONE node's place in time: split it, trim an edge, move it.
"The commands over a node's place in time: split it, trim an edge, move it —
and, where the symbol holding it is drawn as a lane, re-span its siblings to
make room.
A `:span` is in the node's OWN frames and its `:time` says where those land in
its parent, and that is true of EVERY node — which is why these three are not
lane commands, though a lane of cels is where they were first needed. A cel in
a lane, a symbol placed straight into a shot, a shape that exists for part of
one: each is a span in a parent's frame space, and a span in a parent's frame
space is the whole of what these commands touch. They were gated on a lane for
as long as a lane was the only thing anybody had timed.
its parent, and that is true of EVERY node. A clip in a sequence, a symbol
placed straight into a shot, a shape that exists for part of one: each is a
span in a parent's frame space, and a span in a parent's frame space is the
whole of what these commands touch.
THE COORDINATE IS ALWAYS THE PARENT'S. For a cel the parent is its lane, so
`host-frame` reads lane time exactly as the lane commands always did; for a
node sitting straight in the symbol it reads the symbol's own frames. One rule,
so a caller holding a node does not branch on what it sits in.
THE COORDINATE IS ALWAYS THE PARENT'S. `host-frame` reads the frame space the
node is positioned in, whatever that is, so a caller holding a node does not
branch on what it sits in.
A GROUP IS REFUSED. Dividing a group means deciding what becomes of its
children, and nothing in a span says: the right half of a split lane would
reference none of its cels, and a span that narrows past a child hides it
without saying so. `domain/lane` holds the commands for a sequence, which are
the ones that ripple siblings or leave a gap.
A GROUP IS REFUSED where one node is being divided. Dividing a group means
deciding what becomes of its children, and nothing in a span says: a span that
narrows past a child hides it without saying so.
`finish` lives here because every command in this namespace and every one in
`domain/lane` commits through it."
(:require [arthur.domain.clip :as clip]
WHY THE SEQUENCE COMMANDS ARE HERE TOO. They used to be `domain/lane`, gated on
a group with `:layout :sequence`, because a lane was the only thing anybody had
timed. There is no such group any more — the SYMBOL is the container and a lane
is how the timeline draws one, `symbol/lane?` — so their subject is a symbol and
its children, which is the same subject as everything else here: one write to
one node's span, with the siblings re-spanned around it. See
`docs/lane-is-a-view-plan.md`.
THE CLAIM-TIME RULE FOLLOWS THE MODE. In lane mode, placing, moving or growing
over occupied frames TRIMS what it lands on — trimming the incumbent, removing
one wholly covered, splitting one it lands inside — so the result has no overlap
because the operation that could have made one did not. Outside lane mode
nothing is enforced, because overlapping children are what compositing IS.
EVERY COMMAND IS ONE STEP AND ALL OF IT. Each returns `{:clip :selection}` or
`{:refused reason}` — never a half-applied edit, and never a document that
`clip/problems` would reject. A command that cannot say what the person meant
refuses and says why, rather than picking for them: the overflow policy is a
caller's `:extent`, and decoupling shared content is its own command instead of
something an ordinary edit does silently.
IDS COME FROM THE CALLER, because a clip's identity is a uuid and this namespace
is pure. Ids for new CONTENT are derived from the drawing being copied —
`clip/free-id` is pure too, and `drawing-a-2` says what it came from in a way
`symbol-7` does not.
`finish` lives here because every command in this namespace commits through it."
(:require [arthur.domain.bring :as bring]
[arthur.domain.clip :as clip]
[arthur.domain.node :as node]
[arthur.domain.symbol :as symbol]))
@ -30,32 +53,43 @@
"Commit `nodes` as symbol `sid`'s, or refuse.
THE SHOT LENGTH IS AUTHORED. `:frames` is the symbol's window — how long the
shot IS — and the occupied extent of its lanes is a different fact derived
from the cels. A command may GROW the window when the caller says
`:grow-symbol`, and never shrinks it: emptying the end of a shot leaves a shot
with empty frames at the end, which is a true statement about what somebody
authored. Deriving the window from the extent instead would make deleting the
last drawing silently shorten the film.
shot IS — and where its clips reach is a different fact derived from them. A
command may GROW the window when the caller says `:grow-symbol`, and never
shrinks it: emptying the end of a shot leaves a shot with empty frames at the
end, which is a true statement about what somebody authored. Deriving the window
from the reach instead would make deleting the last drawing silently shorten the
film.
So there are two numbers and this function keeps them apart: `needed` is where
the cels reach, `:frames` is what was authored, and the only way the
second follows the first is a caller asking.
the clips reach, `:frames` is what was authored, and the only way the second
follows the first is a caller asking.
Only LANES are measured for reach. A node placed straight in a shot may hang
off the end of it — that is an ordinary thing to author and the window is
what crops it — whereas a lane's cels are a sequence whose length is the
thing being edited."
Only a symbol drawn AS A LANE is measured for reach. A node placed into a
composition may hang off the end of it — that is an ordinary thing to author and
the window is what crops it — whereas a lane's clips are a sequence whose length
is the thing being edited.
THE OVERLAP INVARIANT IS ENFORCED HERE, and here is the only place it needs to
be: this is the single commit path for every sequence command, it validates
before it returns, and it refuses rather than half-applying. So no command can
commit an overlap in lane mode, and `symbol/overlaps` turning up anything is a
bug in a command rather than a state to design around."
[clip sid nodes selection extent]
(let [sym (clip/symbol clip sid)
reach (for [[id n] nodes :when (node/lane? n)
child (symbol/lane-clips nodes id)
:let [m (symbol/frame-map nodes id)
end (second (node/placed-span child))]]
(when m (+ (:at m) (/ end (:rate m)))))
needed (js/Math.ceil (apply max 0 (keep identity reach)))
ps (symbol/problems (assoc sym :nodes nodes))]
lane? (symbol/lane? sym)
after (assoc sym :nodes nodes)
needed (if-not lane?
0
(js/Math.ceil (apply max 0 (keep #(second (node/placed-span %))
(symbol/children nodes)))))
ps (symbol/problems after)
clashing (when lane? (symbol/overlaps after))]
(cond
(seq ps) {:refused (first ps)}
(seq clashing)
{:refused (str "that would put " (pr-str (ffirst clashing)) " and "
(pr-str (second (first clashing)))
" on screen over the same frames of a lane")}
(not (#{:keep :grow-symbol} extent)) {:refused "choose an explicit shot-length policy"}
(and (> needed (:frames sym)) (= :keep extent))
{:refused (str "the edit needs " needed " frames; extend the shot to continue")
@ -73,7 +107,7 @@
;; and `:playback` are untouched — which is why trimming the front of a playing
;; insert starts it later in its source instead of resetting it, and why the two
;; halves of a split go on meaning what the one node meant.
;; Trim, split and `lane/blank` are all this one operation, applied differently.
;; Trim, split and `blank` are all this one operation, applied differently.
(defn local
"Parent frame `f` as one of `n`'s own frames."
@ -89,8 +123,10 @@
(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
in. Nil through a stepped or looping ancestor, where one frame of the symbol
is not one frame of the parent and there is no single answer to give."
in. For a clip of a lane that is the symbol's own frames, because the symbol is
the container and the clip has no parent. Nil through a stepped or looping
ancestor, where one frame of the symbol is not one frame of the parent and there
is no single answer to give."
[clip sid id f]
(let [nodes (get-in clip [:symbols sid :nodes])]
(when-let [{:keys [at rate]} (symbol/frame-map nodes (:parent (get nodes id)))]
@ -98,7 +134,7 @@
(defn- subject
"The node `id` names, as `{:node n}`, or `{:refused why}` where these commands
have nothing to act on. The one guard all three share."
have nothing to act on. The one guard they share."
[nodes id]
(let [n (get nodes id)]
(cond
@ -109,6 +145,13 @@
{:refused "this is on screen for the whole shot, so it has no edges to cut"}
:else {:node n})))
(defn- siblings
"The other clips of `sid`'s sequence, or nil where `sid` is not drawn as a lane
and so has no sequence to re-span."
[clip sid nodes id]
(when (symbol/lane? (clip/symbol clip sid))
(remove #(= id (:id %)) (symbol/children nodes))))
(defn split
"Cut node `id` in two at parent frame `cut`. The left piece keeps its
identity; the right gets `new-id`.
@ -125,8 +168,8 @@
THE RIGHT PIECE KEEPS THE ORIGINAL'S `:z`. Two halves of one thing draw at
one depth; nothing orders them against each other, because they are never on
screen on the same frame. Cels in a lane do not consult `:z` at all —
`symbol/lane-clips` sorts them by where they start.
screen on the same frame. A lane's clips do not consult `:z` at all —
`symbol/children` sorts them by where they start.
The right piece is the selection, because it is the piece that was made."
[clip sid id cut new-id]
@ -148,10 +191,10 @@
"Move one edge of node `id` to parent frame `to`, without disturbing anything
else at all.
TRIM NARROWS. Lengthening a cel is `lane/extend-hold`, which carries a ripple
policy and a shot-length policy because it needs them; letting trim grow as
well would give one gesture two sets of rules and a way to overlap its
neighbour. `edge` is `:in` or `:out`.
TRIM NARROWS. Lengthening is `resize-out`, which carries a ripple policy and a
shot-length policy because it needs them; letting trim grow as well would give
one gesture two sets of rules and a way to overlap its neighbour. `edge` is
`:in` or `:out`.
The source clock is untouched, so trimming the front of a playing insert
starts it later INTO its animation rather than restarting it — which is the
@ -168,32 +211,18 @@
{:refused (str "frame " to " is not inside this; trim narrows it")}
:else (finish clip sid (assoc nodes id (edged node edge to)) id :keep))))
(defn resize-out
"Put one node's right edge at parent frame `to`, allowing it to grow.
This is for an ordinary timeline clip, including audio. Lane cels use
`lane/resize-out`, because only a lane has neighbours to trim or ripple."
[clip sid id to]
(let [nodes (get-in clip [:symbols sid :nodes])
{:keys [node refused]} (subject nodes id)
[lo _] (when node (node/placed-span node))]
(cond
refused {:refused refused}
(not (integer? to)) {:refused "an edge goes to a whole frame"}
(not (< lo to)) {:refused "a clip must keep at least one frame"}
:else (finish clip sid (assoc nodes id (edged node :out to)) id :keep))))
(defn move
"Put node `id` at parent frame `to`, leaving its own length, source and
corrections alone — and, in a lane, every other cel.
corrections alone — and, in a lane, every other clip.
One write to `:time :at`. A destination that would overlap a neighbour IN A
LANE is refused rather than rippled or overwritten: moving a drawing and
re-timing the ones around it are different intentions, and a move that
silently pushed the rest would be the second one wearing the first one's name.
Clear the room first — `lane/blank` makes a gap, `trim` shortens a neighbour.
Outside a lane there is no such rule to break: things placed in a composition
are allowed to be on screen together, so the move simply happens."
Clear the room first — `blank` makes a gap, `trim` shortens a neighbour — or
say you meant to claim it, which is `adopt`, what a body drag does.
Outside lane mode there is no such rule to break: things placed in a
composition are allowed to be on screen together, so the move simply happens."
[clip sid id to]
(let [nodes (get-in clip [:symbols sid :nodes])
{:keys [node refused]} (subject nodes id)]
@ -205,3 +234,488 @@
(if (not= to (first (node/placed-span moved)))
{:refused "timing through a stepped or looping parent is not supported"}
(finish clip sid (assoc nodes id moved) id :keep))))))
;; ---------------------------------------------------------------------------
;; the sequence: one edge edit, with the siblings re-spanned around it
(defn- trimmed-into-a-sequence
"`nodes` with every clip's right edge pulled back to where the next one starts,
and any clip the next one wholly covers removed.
THE SAME CLAIM-TIME RULE, APPLIED ALL AT ONCE. Later claims from earlier
everywhere it has to, which is the rule every other command here follows one
edit at a time; doing it as a pass is only what makes the answer to \"make this
a lane\" one undo step."
[nodes]
(reduce
(fn [ns [earlier later]]
(let [[lo hi] (node/placed-span (get ns (:id earlier)))
[next-lo _] (node/placed-span later)]
(cond
(nil? lo) ns
(<= hi next-lo) ns
(<= next-lo lo) (dissoc ns (:id earlier))
:else (assoc ns (:id earlier) (edged (get ns (:id earlier)) :out next-lo)))))
nodes
(partition 2 1 (symbol/children nodes))))
(defn draw-as-lane
"Turn symbol `sid`'s lane mode on or off. `{:clip c}` or `{:refused why}`.
OFF IS ALWAYS POSSIBLE: a composition has no invariant to break, so dropping
the hint drops the rules with it and nothing in the document moves.
ON IS THE ONE PLACE A PERSON CAN ASK FOR THE IMPOSSIBLE. Every other command
maintains the sequence; this one asks a symbol whose clips may already be on
screen together to start being one, and there is no answer that does not throw
frames away. So it refuses and says how many clips it would have to trim,
carrying `:required-trim` for the retry the UI offers as one button — the same
shape as `finish`'s `:required-frames`. With `trim?` it does it: later claims
from earlier, which is the rule everything else here already follows."
[clip sid on? {:keys [trim?]}]
(let [sym (clip/symbol clip sid)]
(cond
(nil? sym) {:refused "there is no such symbol"}
(not on?) {:clip (update-in clip [:symbols sid] dissoc :display)}
:else
(let [clashing (symbol/overlaps sym)]
(cond
(empty? clashing) {:clip (assoc-in clip [:symbols sid :display] :lane)}
(not trim?)
{:refused (str "drawing this as a lane means trimming "
(count clashing) " clip"
(when (< 1 (count clashing)) "s")
" that overlap a neighbour")
:required-trim (count clashing)}
:else
(let [nodes (trimmed-into-a-sequence (:nodes sym))
after (assoc sym :nodes nodes :display :lane)]
(if (seq (symbol/overlaps after))
{:refused "these clips cannot be trimmed into a sequence"}
{:clip (assoc-in clip [:symbols sid] after)})))))))
(defn resize-out
"Put clip `id`'s right edge at parent frame `to`, allowing it to grow.
IN A LANE this claims time. Without `ripple?`, growing consumes the starts of
the clips it reaches: wholly covered clips disappear and the last partially
covered one is trimmed. Shrinking leaves a gap. With `ripple?`, every clip
beginning at or after the old edge moves by the same delta, in either
direction, so their contents are preserved. Either way there is no overlap,
because the operation that could have made one did not.
OUTSIDE A LANE it is one write to one span and nothing else moves, because
things placed in a composition are allowed to be on screen together. One
gesture, and the mode says which rule it plays by."
[clip sid id to {:keys [extent ripple?] :or {extent :keep ripple? false}}]
(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
(filter #(>= (first (node/placed-span %)) old-out)
(siblings clip sid nodes id)))]
(cond
refused {:refused refused}
(not (integer? to)) {:refused "an edge goes to a whole frame"}
(not (< lo to)) {:refused "a clip must keep at least one frame"}
(= to old-out) {:clip clip :selection id}
: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)))))
(defn resize-in
"Put clip `id`'s left edge at parent frame `to`. Shrinking leaves a gap;
in a lane, growing left consumes earlier clips symmetrically with `resize-out`."
[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)))]
(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)))))
(defn roll
"Move the shared boundary between adjacent clips `left-id` and `right-id`.
This is deliberately only the composition of the two ordinary edge edits."
[clip sid left-id right-id to]
(let [nodes (get-in clip [:symbols sid :nodes])
left (get nodes left-id)
right (get nodes right-id)
[llo lhi] (when left (node/placed-span left))
[rlo rhi] (when right (node/placed-span right))]
(cond
(not (symbol/lane? (clip/symbol clip sid)))
{:refused "a rolling edit needs a symbol drawn as a lane"}
(not (and llo rlo (nil? (:parent left)) (nil? (:parent right))))
{:refused "a rolling edit needs two clips of one sequence"}
(not= lhi rlo) {:refused "a rolling edit needs one shared boundary"}
(not (integer? to)) {:refused "a clip edge goes to a whole frame"}
(not (< llo to rhi)) {:refused "both clips must keep at least one frame"}
:else
(let [left-result (resize-out clip sid left-id to {})]
(if (:refused left-result)
left-result
(resize-in (:clip left-result) sid right-id to))))))
(defn blank
"Clear frames `[a b)` of symbol `sid`, leaving a GAP.
A gap is not a drawing. Nothing is invented to cover those frames and nothing
closes the hole — the clips after it stay where they are, because emptying
frames and re-timing a performance are different intentions.
What it does to each clip it meets is `edged`, applied three ways: one wholly
inside is removed, one overlapping an end is trimmed to it, and the one that
spans the whole range is split, which is the only case that needs `id`. Their
drawings stay in the library — a symbol does not own its content, and a drawing
whose last clip is gone is still a drawing somebody made."
[clip sid [a b] {:keys [id]}]
(let [nodes (get-in clip [:symbols sid :nodes])
lane? (symbol/lane? (clip/symbol clip sid))
members (when lane? (symbol/children nodes))
spanning (when members
(first (filter #(let [[lo hi] (node/placed-span %)] (and (< lo a) (> hi b)))
members)))]
(cond
(not lane?) {:refused "clearing a range of frames needs a symbol drawn as a lane"}
(not (and (integer? a) (integer? b) (< a b)))
{:refused "a range to blank is whole frames, and not empty"}
(and spanning (or (nil? id) (contains? nodes id)))
{:refused "blanking inside one clip splits it, which needs a free ID for the remainder"}
:else
(let [nodes (reduce
(fn [ns n]
(let [[lo hi] (node/placed-span n)]
(cond
(or (<= hi a) (>= lo b)) ns
(and (< lo a) (> hi b))
(-> ns
(assoc (:id n) (edged n :out a))
(assoc id (assoc (edged n :in b) :id id :z (str "a-" id))))
(and (>= lo a) (<= hi b)) (dissoc ns (:id n))
(< lo a) (assoc ns (:id n) (edged n :out a))
:else (assoc ns (:id n) (edged n :in b)))))
nodes members)]
;; NOTHING SENSIBLE IS SELECTED by emptying frames, so nothing is: a
;; split names its remainder, and otherwise the caller keeps whatever was
;; 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.
Returns {:clip :selection} or {:refused :required-frames?}; never partially edits."
[clip sid id delta {:keys [extent] :or {extent :keep}}]
(let [nodes (get-in clip [:symbols sid :nodes])
n (get nodes id)
rate (:rate (node/time-of n))
span (:span n)]
(cond
(not (symbol/lane? (clip/symbol clip sid)))
{:refused "a hold is lengthened in a symbol drawn as a lane"}
(nil? (node/placed-span n)) {:refused "select a clip in the lane"}
(some? (:parent n)) {:refused "select a clip of the lane itself"}
(not (and (integer? delta) (not (zero? delta)))) {:refused "hold change must be a nonzero whole number of frames"}
(not (zero? (:speed (node/playback-of n)))) {:refused "hold length applies to a held drawing"}
(<= (+ (second span) (* rate delta)) (first span)) {:refused "a drawing must keep a positive exposure"}
:else
(let [[_ boundary] (node/placed-span n)
later (filter #(>= (first (node/placed-span %)) boundary)
(siblings clip sid nodes id))
nodes (assoc-in nodes [id :span 1] (+ (second span) (* rate delta)))
nodes (reduce (fn [ns sibling]
(update-in ns [(:id sibling) :time :at] (fnil + 0) delta))
nodes later)]
(finish clip sid nodes id extent)))))
(defn place-symbol
"Place arbitrary symbol `source-id` into `sid` as a naturally playing clip at
frame `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
storing an overlap. Outside one it is simply placed. This is the generic
operation behind dropping a library symbol into the timeline; one-frame held
drawing creation remains a policy of `append-drawing`/`overwrite-drawing`,
not a different kind of container."
[clip store sid id source-id at
{: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))))]
(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)))))))
(defn adopt
"Move an existing clip of `sid` to frame `at`, CLAIMING the time it lands on.
Its source, span, transforms, corrections, and identity come with it; in a lane
the destination interval is claimed with the same trimming as a pool drop. This
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}}]
(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))]
(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)))))))
;; ---------------------------------------------------------------------------
;; putting drawings in a sequence
(defn- held
"A one-frame held clip of `drawing-id`, starting at frame `at`.
Held rather than playing, and one frame rather than the length of what it
places: a clip's duration is the sequence's business — `extend-hold` and
`resize-out` are how it changes — and reading it off the content would make
placing a ten-frame animation and holding its first drawing the same gesture."
[id drawing-id at]
{:id id :kind :instance :z (str "a-" id)
:span [0 1] :time {:at at :rate 1}
:source {:symbol drawing-id} :playback {:in 0 :speed 0 :end :stop}})
(defn- sequence-end
"Where `sid`'s occupied frames stop."
[nodes]
(apply max 0 (map #(second (node/placed-span %)) (symbol/children nodes))))
(defn- place
"Put a held clip of `drawing-id` into `sid` at frame `at`, and RIPPLE:
everything starting at or after it moves later by its duration.
There is one placement function and `:end` is a position like any other, so
appending is not a different operation from inserting — the end is just where
nothing has to move. Overwriting is the other policy and is NOT this: taking
frames away from the clip already there is trimming, which is its own command
and not something placing a drawing should do on the quiet.
`:frame` in the result is where it landed, in the symbol's own frames, for a
caller that wants to look at what it just made."
[clip sid id drawing-id at extent ripple?]
(let [nodes (get-in clip [:symbols sid :nodes])
at (if (= :end at) (sequence-end nodes) at)
n (held id drawing-id at)
[lo hi] (node/placed-span n)
;; RIPPLE FOLLOWS THE MODE. Pushing later siblings is what inserting
;; into a sequence means; in a composition there is no "later sibling"
;; to push, because being on screen together is the point.
later (when (and ripple? (symbol/lane? (clip/symbol clip sid)))
(filter #(>= (first (node/placed-span %)) lo) (symbol/children nodes)))
nodes (reduce (fn [ns sibling]
(update-in ns [(:id sibling) :time :at] (fnil + 0) (- hi lo)))
(assoc nodes id n) later)
result (finish clip sid nodes id extent)]
(cond-> result
(:clip result) (assoc :frame at))))
(defn- placeable
"Why a held clip cannot go into `sid` at `at`, or nil."
[clip sid id at]
(let [nodes (get-in clip [:symbols sid :nodes])
;; INSIDE a clip is not a position for another one, IN A LANE. Splitting
;; that clip is what makes it two, and doing it here would be one command
;; quietly performing two: the caller asks for `split` and then places.
;; In a composition landing inside something is not a collision at all.
inside (when (and (number? at) (symbol/lane? (clip/symbol clip sid)))
(some (fn [n] (let [[lo hi] (node/placed-span n)]
(when (< lo at hi) n)))
(symbol/children nodes)))]
(cond
(contains? nodes id) "the new clip ID is already used"
(not (or (= :end at) (and (integer? at) (not (neg? at)))))
"a position is :end or a whole frame"
inside (str "frame " at " is inside a clip; split it first"))))
(defn append-drawing
"Append fresh empty content and a held clip of it. IDs come from the
caller so a command is deterministic and replayable.
Fresh content, not a blank range: a sequence with no clip over a frame shows
nothing there already, and a drawing nobody has drawn in is a different thing
from a gap."
[clip sid id drawing-id {:keys [at extent] :or {extent :keep at :end}}]
(if-let [why (or (placeable clip sid id at)
(when (clip/symbol clip drawing-id) "the new drawing ID is already used"))]
{:refused why}
(place (assoc-in clip [:symbols drawing-id]
{:id drawing-id :name (name drawing-id) :fps (clip/fps clip sid) :frames 1 :nodes {}})
sid id drawing-id at extent true)))
(defn reuse-drawing
"Append a held clip of content the document ALREADY has, so the same
drawing is exposed twice and editing it changes both clips.
This is the command `make-unique` is the undo of, and the reason they are two
commands: reuse is a decision to share, and sharing is not something to
discover later when an edit turns up somewhere else."
[clip sid id drawing-id {:keys [at extent] :or {extent :keep at :end}}]
(if-let [why (or (placeable clip sid id at)
(when-not (clip/symbol clip drawing-id) "there is no such drawing to reuse")
;; Placing something that contains this symbol would close a
;; loop, and a sequence is no different from any other placement.
(when (clip/contains-symbol? clip drawing-id sid)
"a symbol cannot go inside itself"))]
{:refused why}
(place clip sid id drawing-id at extent true)))
(defn- copied
"A copy of symbol `from`, as `{:clip :id}`.
SHALLOW by default: its own nodes and channels are copied, and its references
to other symbols are kept, so a head built out of reusable eyes still uses
those eyes. `deep?` copies everything it places as well, with new ids
throughout, for a drawing that must share nothing — the distinction the
shallow copy cannot make on its own, and a promise of independence that only
the deep one keeps."
[clip from deep?]
(if deep?
(let [{c :clip ids :ids} (bring/symbols clip clip [from] {})]
{:clip c :id (ids from)})
(let [id (clip/free-id (:symbols clip) from)]
{:clip (assoc-in clip [:symbols id] (assoc (clip/symbol clip from) :id id))
:id id})))
(defn duplicate-drawing
"Append a held clip of a COPY of what clip `id` places, for when
the drawing on screen is the starting point for the next one.
The copy is of the content only. The new clip is a plain one-frame hold
rather than a copy of `id`'s own transform or corrections: those belong to
that clip, and carrying them over would make duplicating a drawing quietly
duplicate the treatment of one use of it."
[clip sid id new-id {:keys [at extent deep?] :or {extent :keep at :end}}]
(let [n (get-in clip [:symbols sid :nodes id])
from (node/source n)]
(if-let [why (or (when-not from "select a clip to duplicate")
(when-not (clip/symbol clip from) "the drawing it places is missing")
(placeable clip sid new-id at))]
{:refused why}
(let [{c :clip copy :id} (copied clip from deep?)]
(place c sid new-id copy at extent true)))))
(defn overwrite-drawing
"Put a fresh one-frame drawing at frame `at`, replacing whatever was there and
leaving every other clip where it was.
This is `blank` and placement composed in ONE command and therefore one undo
step. `remainder-id` is used only when clearing the frame cuts one clip into
two; ids still come from the caller because this namespace is pure."
[clip sid id drawing-id at {:keys [extent remainder-id] :or {extent :keep}}]
(let [nodes (get-in clip [:symbols sid :nodes])]
(if-let [why (cond
(not (and (integer? at) (not (neg? at))))
"a position is a nonnegative whole frame"
(contains? nodes id) "the new clip ID is already used"
(or (= id remainder-id) (contains? nodes remainder-id))
"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))))))
(defn make-unique
"Point clip `id` at a private copy of its content, leaving every other
clip of that drawing sharing the original.
Refused when nothing else uses it: a drawing with one clip is already
unique, and answering with a silent copy would leave a second identical symbol
in the library for no reason a person could see."
[clip sid id {:keys [deep?]}]
(let [n (get-in clip [:symbols sid :nodes id])
from (node/source n)
elsewhere (for [[osid osym] (:symbols clip)
[oid on] (:nodes osym)
:when (and (= from (node/source on)) (not= [sid id] [osid oid]))]
[osid oid])]
(if-let [why (or (when-not from "select a clip to make unique")
(when-not (clip/symbol clip from) "the drawing it places is missing")
(when (empty? elsewhere) "nothing else uses this drawing"))]
{:refused why}
(let [{c :clip copy :id} (copied clip from deep?)
c (assoc-in c [:symbols sid :nodes id :source :symbol] copy)
ps (clip/problems c)]
(if (seq ps) {:refused (first ps)} {:clip c :selection id})))))

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

@ -96,16 +96,25 @@
[nodes id]
(dec (count (lineage nodes id))))
(defn lane-clips
"The symbol clips of lane `lane`, in timeline order.
(defn children
"The symbol's own clips — the nodes placed directly in it — in timeline order.
Sorted by where they START, not by `:z`: a lane's blocks follow one another in
time, and two of them cannot be in the same place for `:z` to decide between.
Ties go to the id so the order is the same on every run."
[nodes lane]
THE SYMBOL IS THE CONTAINER. There is no lane node to ask for its members: a
symbol drawn as a lane draws THESE, and the sequence commands re-span THESE.
See `docs/lane-is-a-view-plan.md`.
Sorted by where they START, not by `:z`: blocks in a sequence follow one
another in time, and two of them cannot be in the same place for `:z` to
decide between. Ties go to the id so the order is the same on every run.
A NODE WITH NO SPAN IS NOT IN THE SEQUENCE. A shape on screen for the whole
shot has no `[in out)` to follow anything else, so it is not something an edge
edit can trim or ripple, and a command that destructured its nil span would
fail on the most ordinary node there is."
[nodes]
(->> (vals nodes)
(filter #(= lane (:parent %)))
(sort-by (juxt #(or (first (node/placed-span %)) 0) #(str (:id %))))
(filter #(and (nil? (:parent %)) (node/placed-span %)))
(sort-by (juxt #(first (node/placed-span %)) #(str (:id %))))
vec))
(defn frame-map
@ -131,61 +140,47 @@
(<= (or (:expose t) 1) 1))
(recur (:parent n) (conj seen id) (conj chain n)))))))
(defn lanes
"The symbol's lanes, front-most first.
(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.
SAME ORDER THE TIMELINE DRAWS ITS ROWS IN — `:z` descending, the id breaking
ties so it is stable across runs, so \"the first lane\" means the same thing
to the view that shows it and to commands that inspect the lane order.
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
says how the timeline draws the symbol and, because the editing rules follow
the mode, which rules an edge drag inside it plays by. It is on the symbol
rather than in editor state so that those rules are reproducible between two
people looking at one document, and it is a field rather than something derived
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.
Only this symbol's own: a lane inside a nested instance belongs to that
symbol, and aiming a drawing at it is entering it first."
[nodes]
(->> (vals nodes)
(filter node/lane?)
(sort-by (fn [n] [(or (:z n) "") (str (:id n))]))
reverse
vec))
The only things allowed to read it are the timeline and `span/finish`'s
overlap check. See `docs/lane-is-a-view-plan.md`."
[sym]
(= :lane (:display sym)))
(defn lane-problems
"What makes a lane not a lane. A SEQUENCE is the one composition rule the node
map carries — ordinary groups compose freely — so it is checked here, beside
the parent and stencil references, rather than wherever a command happens to
build one.
(defn overlaps
"The pairs of `sym`'s clips that are on screen over the same frames, as
`[[a b] ...]` of ids. Empty for a symbol whose clips form a sequence.
Clips must be finite and non-overlapping. An accidental overlap
is refused rather than resolved by draw order: two drawings exposed on one
frame of one lane is a document nobody meant to write, and picking a winner
would hide it. Empty lanes are valid — a lane is made before it is filled.
A BUG REPORT, NOT A CONDITION TO DESIGN AROUND. In lane mode this cannot
happen: placing claims time, so anything placed, moved or grown over occupied
frames TRIMS what it lands on, and `span/finish` — the one commit path for
every sequence command — refuses rather than committing one. So an overlap that
appears anyway is a defect in a command.
A SOUND IS A CLIP TOO. A lane is the one temporal container, so audio sits in
one on the same terms as picture: its own frames in `:span`, where they land
in `:time`, and no overlap with its neighbours. What a lane may NOT hold is a
mixture, and that is the explicit capability the model wanted rather than a
per-frame guess: all picture or all sound, so what the lane does with the
frame it owns is answered by the lane and not by the clip that happens to be
under the playhead."
[nodes]
(vec
(mapcat
(fn [[id lane]]
(when (node/lane? lane)
(let [children (filter #(= id (:parent %)) (vals nodes))
valid? (fn [n]
(and (contains? #{:instance :audio} (:kind n))
(empty? (node/problems n))
(:span n)
(every? node/finite-number? (node/placed-span n))))
kept (filter valid? children)
intervals (sort-by first (map node/placed-span kept))]
(concat
(for [n children :when (not (valid? n))]
(str "sequence " id " needs finite symbol or sound clips: " (:id n)))
(when (< 1 (count (into #{} (map :kind) kept)))
[(str "lane " id " holds picture or sound, not both")])
(when (some (fn [[[_ b] [c _]]] (> b c)) (partition 2 1 intervals))
[(str "lane " id " has overlapping clips")])))))
nodes)))
Which is why it is NOT `clip/problems`, which means the document will not load:
a display hint must never be able to stop a document loading, and a document
that somehow arrives holding an overlap still opens and is drawn visibly wrong.
Nor `clip/conflicts`, which means a person has a decision to make. This is
neither."
[sym]
(let [spans (for [n (children (:nodes sym))
:let [[lo hi] (node/placed-span n)]
:when (and (node/finite-number? lo) (node/finite-number? hi))]
[lo hi (:id n)])]
(vec (for [[[_ b x] [c _ y]] (partition 2 1 (sort-by (juxt first second str) spans))
:when (> b c)]
[x y]))))
(defn order
"Node ids in topological order: every node after its parent.
@ -708,8 +703,12 @@
and saved leaves point at, so renaming a symbol must not change it.
`:width` and `:height` are the symbol's own stage, and are absent until someone
sets them: a symbol without them uses the clip's — see `clip/stage`."
#{:id :name :frames :fps :width :height :nodes :palette})
sets them: a symbol without them uses the clip's — see `clip/stage`.
`:display` is how the TIMELINE draws the symbol — `:lane` for its clips as
blocks on one row — and is saved because two people editing one document must
play by the same editing rules. See `lane?`."
#{:id :name :frames :fps :width :height :nodes :palette :display})
(defn problems
"Human-readable reasons this symbol will not evaluate. Empty means it will.
@ -727,7 +726,6 @@
(if-not (map? nodes)
[":nodes must be a map of id -> node"]
(-> []
(into (lane-problems nodes))
(into (for [[id n] nodes
:when (not= id (:id n))]
(str "node under key " (pr-str id) " has :id " (pr-str (:id n)))))

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

@ -6,7 +6,7 @@
address of every block this produces."
(:require [arthur.domain.bring :as bring]
[arthur.domain.clip :as clip]
[arthur.domain.lane :as lane]
[arthur.domain.span :as span]
[arthur.events.edit :as edit]
[arthur.events.ui :as ui]
[arthur.events.playback :as pb]
@ -497,9 +497,8 @@
(rf/reg-event-fx
::converted
;; A TAKE IS A CLIP IN A LANE, like everything else that enters the timeline.
;; It used to be placed straight into the open symbol as a row of its own,
;; which was the one way to get temporal content that no lane owned.
;; A TAKE IS A CLIP LIKE ANY OTHER, placed into whichever symbol the drop names
;; — see `ui/drop-destination` — rather than into a container invented for it.
(fn [{:keys [db]} [_ {{:keys [name frame point range target]} :request footage-id :footage-id}
built]]
(let [entry (store/entry (:clip/current db))
@ -510,10 +509,10 @@
st (merge (:store entry) (:store built))
imported-frames (clip/output-frames clip sid)
source-fps (get-in built [:clip :fps])
where (ui/lane-destination db clip st frame target :picture)
where (ui/drop-destination db clip st frame target)
result (if (:refused where)
where
(lane/place-symbol (:clip where) st (:sid where) (:lane-id where)
(span/place-symbol (:clip where) st (:sid where)
uuid sid (:at where)
{:extent :grow-symbol :point point
:remainder-id (random-uuid)}))]
@ -528,9 +527,6 @@
:source-inputs]))))]
{:db (-> db
(update :ui dissoc :convert)
(cond-> (:made? where)
(assoc-in [:ui :target] {:sid (:sid where) :id (:lane-id where)
:path [(:lane-id where)]}))
(assoc-in [:ui :selection]
[:node (:sid where) uuid (conj (vec (:path where)) uuid)])
(update :footage merge

11
frontend/src/arthur/events/project.cljs
View file

@ -24,6 +24,7 @@
(:require [arthur.db :as db]
[arthur.domain.bring :as bring]
[arthur.domain.clip :as clip]
[arthur.domain.span :as span]
[arthur.domain.leaf :as leaf]
[arthur.domain.node :as node]
[arthur.events.edit :as edit]
@ -35,7 +36,6 @@
[arthur.events.footage :as footage]
[arthur.events.playback :as pb]
[arthur.events.ui :as ui]
[arthur.domain.lane :as lane]
[arthur.footage.store :as store]
[arthur.flow.address :as address]
[arthur.flow.ingest :as ingest]
@ -171,21 +171,18 @@
uuid (random-uuid)
{:keys [clip ids]} (bring/symbols (:clip entry) (:clip other) [sid] {})
st (merge (:store entry) (:store other))
;; A symbol from another project arrives as a clip in a lane, the same
;; A symbol from another project arrives as an ordinary clip, the same
;; as one from this project's pool.
where (ui/lane-destination db clip st frame target :picture)
where (ui/drop-destination db clip st frame target)
result (if (:refused where)
where
(lane/place-symbol (:clip where) st (:sid where) (:lane-id where)
(span/place-symbol (:clip where) st (:sid where)
uuid (ids sid) (:at where)
{:extent :grow-symbol :point point
:remainder-id (random-uuid)}))]
(if-let [why (or (:refused where) (:refused result))]
{:db (update db :project merge {:status why})}
{:db (-> (edit/edit-entry db #(assoc % :clip (:clip result) :store st))
(cond-> (:made? where)
(assoc-in [:ui :target] {:sid (:sid where) :id (:lane-id where)
:path [(:lane-id where)]}))
(assoc-in [:ui :selection]
[:node (:sid where) uuid (conj (vec (:path where)) uuid)])
(update :project merge {:status (str "brought in " label)}))

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

@ -24,7 +24,6 @@
[arthur.domain.gesture :as gesture]
[arthur.domain.nest :as nest]
[arthur.domain.node :as node]
[arthur.domain.lane :as lane]
[arthur.domain.span :as span]
[arthur.domain.symbol :as symbol]
[arthur.events.edit :as edit]
@ -56,7 +55,7 @@
[:clip :symbols sid :nodes id :kind]))]
(cond-> (-> db
(assoc-in [:ui :selection] selection)
(update :ui dissoc :points :lane-retry))
(update :ui dissoc :points :retry))
(and (= :node kind) path (not sound?))
(update-in [:ui :expanded] (fnil into #{}) (rest (reductions conj [] (pop path)))))))
@ -97,46 +96,26 @@
::set-tone
(fn [db [_ tone]] (assoc-in db [:ui :tone] tone)))
(defn- aimed-lane
"The lane the target names, or nil — including nil for a target aimed at a cel
INSIDE a lane, which is the lane's business and not a lane itself."
[clip db]
(let [{:keys [sid id path]} (get-in db [:ui :target])
n (when id (get-in clip [:symbols sid :nodes id]))]
(when (and n (node/lane? n) (= 1 (count path))
(= sid (get-in db [:ui :open])))
n)))
(defn empty-lane
"The id of a lane of `sid` that has nothing in it, or nil.
EVERY SYMBOL IS BORN WITH A LANE, so the first thing put into one goes
there instead of beside it. An OCCUPIED lane is never chosen this way:
placing claims time, so taking a lane nobody pointed at would trim or delete
what was already in it. That is a fine thing to ask for and not a fine thing
to assume."
[document sid]
(let [nodes (get-in document [:symbols sid :nodes])]
(first (keep (fn [lane]
(when (empty? (symbol/lane-clips nodes (:id lane))) (:id lane)))
(symbol/lanes nodes)))))
(defn apply-lane-command
(defn apply-command
"Commit a successful domain command as one history step. A refused command
leaves the document and history untouched; an overflow offers an explicit retry."
leaves the document and history untouched; an overflow offers an explicit retry.
A COMMAND NEED NOT NAME A SELECTION. Emptying frames deletes what was selected
and has nothing sensible to put in its place, so a nil `:selection` leaves the
selection alone rather than pointing it at a clip nobody asked for."
[db sid result retry]
(if-let [why (:refused result)]
(-> db
(assoc-in [:project :status] why)
(assoc-in [:ui :lane-retry]
(when (:required-frames result) retry)))
(assoc-in [:ui :retry] (when (:required-frames result) retry)))
(let [[_ selected-sid _ path] (get-in db [:ui :selection])
prefix (if (and (= sid selected-sid) (seq path)) (pop path) [])]
(-> db
(edit/transaction (constantly (:clip result)))
(assoc-in [:ui :selection] [:node sid (:selection result) (conj prefix (:selection result))])
(update :ui dissoc :lane-retry)))))
(cond-> (-> db
(edit/transaction (constantly (:clip result)))
(update :ui dissoc :retry))
(:selection result)
(assoc-in [:ui :selection]
[:node sid (:selection result) (conj prefix (:selection result))])))))
(defn apply-correction-command
"Commit one correction command while keeping the complete row address that
@ -170,17 +149,19 @@
db (correction/retry-layer clip sid id path layer-id)))))
(rf/reg-event-db
::new-lane
;; AND AIMED AT, because the reason to make a lane is to draw in it: `add-lane`
;; returns the new lane as its selection, and `apply-lane-command` has already
;; worked out the row path that addresses it.
(fn [db _]
::draw-as-lane
;; THE ONE PLACE A PERSON CAN ASK FOR THE IMPOSSIBLE. Everything else maintains
;; the sequence; this asks a symbol whose clips may already overlap to start
;; being one. `span/draw-as-lane` refuses and says what it would have to trim,
;; and `::retry` is the one button that says do it.
(fn [db [_ sid on? trim?]]
(let [clip (:clip (store/entry (:clip/current db)))
sid (get-in db [:ui :open])
after (apply-lane-command db sid (lane/add-lane clip sid (random-uuid)) nil)]
(cond-> after
(not= (get-in after [:ui :selection]) (get-in db [:ui :selection]))
(assoc-in [:ui :target] (target-of (get-in after [:ui :selection])))))))
result (span/draw-as-lane clip sid on? {:trim? trim?})]
(if-let [why (:refused result)]
(-> db (assoc-in [:project :status] why)
(assoc-in [:ui :retry] (when (:required-trim result) [::draw-as-lane sid on? true])))
(-> db (edit/transaction (constantly (:clip result)))
(update :ui dissoc :retry))))))
(defn- committed
"One appending command, as effects: commit it, and look at what it made.
@ -195,23 +176,17 @@
{:keys [at rate]} (:time (nest/inside clip st (get-in db [:ui :open])
(if (seq path) (pop path) [])
(get-in db [:playback :frame])))]
(cond-> {:db (apply-lane-command db sid result retry)}
(cond-> {:db (apply-command db sid result retry)}
(and (:clip result) (:frame result) rate)
(assoc :dispatch [::playback/seek (+ at (/ (:frame result) rate))]))))
(defn- selected-lane
"The lane a command should act in: the selected lane itself, or the one
holding the selected cel."
[clip sid id]
(let [n (get-in clip [:symbols sid :nodes id])]
(if (node/lane? n) id (:parent n))))
(defn selection-frame
"The playhead as a frame of the symbol that owns `selection`.
A timeline selection carries its path from the open symbol. Walking to the
parent of the selected node crosses every enclosing instance clock before a
lane command converts that owning-symbol frame into lane time."
parent of the selected node crosses every enclosing instance clock, and that
is the whole of it: a clip of a lane has no parent, so the symbol's own frames
ARE the sequence's. One clock where there used to be two."
[clip st open selection frame]
(let [[_ sid _ path] selection]
(if (or (= sid open) (not (seq path)))
@ -223,9 +198,8 @@
(fn [{:keys [db]} [_ extent]]
(let [clip (:clip (store/entry (:clip/current db)))
[_ sid id] (get-in db [:ui :selection])
result (lane/append-drawing clip sid (selected-lane clip sid id)
(random-uuid) (clip/fresh-id clip)
{:extent (or extent :keep)})]
result (span/append-drawing clip sid (random-uuid) (clip/fresh-id clip)
{:extent (or extent :keep)})]
(committed db sid result [::append-drawing :grow-symbol]))))
(rf/reg-event-fx
@ -233,9 +207,9 @@
(fn [{:keys [db]} [_ extent]]
(let [clip (:clip (store/entry (:clip/current db)))
[_ sid id] (get-in db [:ui :selection])
result (lane/reuse-drawing clip sid (selected-lane clip sid id) (random-uuid)
(node/source (get-in clip [:symbols sid :nodes id]))
{:extent (or extent :keep)})]
result (span/reuse-drawing clip sid (random-uuid)
(node/source (get-in clip [:symbols sid :nodes id]))
{:extent (or extent :keep)})]
(committed db sid result [::reuse-drawing :grow-symbol]))))
(rf/reg-event-fx
@ -243,27 +217,26 @@
(fn [{:keys [db]} [_ extent deep?]]
(let [clip (:clip (store/entry (:clip/current db)))
[_ sid id] (get-in db [:ui :selection])
result (lane/duplicate-drawing clip sid id (random-uuid)
{:extent (or extent :keep) :deep? deep?})]
result (span/duplicate-drawing clip sid id (random-uuid)
{:extent (or extent :keep) :deep? deep?})]
(committed db sid result [::duplicate-drawing :grow-symbol deep?]))))
(rf/reg-event-fx
::insert-drawing
;; The playhead is the position: you scrub to where the drawing goes. A lane
;; that is stepped or retimed off whole frames has no single lane frame for a
;; symbol frame, and `lane-frame` says so rather than snapping to one.
;; The playhead is the position: you scrub to where the drawing goes. The
;; symbol's own frames are the sequence's, so there is nothing to convert —
;; only an enclosing stepped or looping instance can leave the playhead on no
;; single frame of it, which `selection-frame` says by answering nil.
(fn [{:keys [db]} [_ extent]]
(let [{clip :clip st :store} (store/entry (:clip/current db))
selection (get-in db [:ui :selection])
[_ sid id] selection
lane (selected-lane clip sid id)
owner-frame (selection-frame clip st (get-in db [:ui :open]) selection
(get-in db [:playback :frame]))
at (when (number? owner-frame) (lane/lane-frame clip sid lane owner-frame))
result (if at
(lane/append-drawing clip sid lane (random-uuid) (clip/fresh-id clip)
{:at at :extent (or extent :keep)})
{:refused "this lane's frames are not the open symbol's"})]
[_ sid] selection
at (selection-frame clip st (get-in db [:ui :open]) selection
(get-in db [:playback :frame]))
result (if (integer? at)
(span/append-drawing clip sid (random-uuid) (clip/fresh-id clip)
{:at at :extent (or extent :keep)})
{:refused "the playhead is not on one frame of this symbol"})]
(committed db sid result [::insert-drawing :grow-symbol]))))
(defn- at-playhead
@ -292,7 +265,7 @@
::split
(fn [db _]
(let [{:keys [clip sid id at]} (at-playhead db)]
(apply-lane-command
(apply-command
db sid (if at (span/split clip sid id at (random-uuid)) no-frame) nil))))
(rf/reg-event-fx
@ -300,30 +273,28 @@
(fn [{:keys [db]} [_ extent]]
(let [{clip :clip st :store} (store/entry (:clip/current db))
selection (get-in db [:ui :selection])
[_ sid id] selection
lane-id (selected-lane clip sid id)
owner-frame (selection-frame clip st (get-in db [:ui :open]) selection
(get-in db [:playback :frame]))
at (when (number? owner-frame) (lane/lane-frame clip sid lane-id owner-frame))
[_ sid] selection
at (selection-frame clip st (get-in db [:ui :open]) selection
(get-in db [:playback :frame]))
result (if (integer? at)
(lane/overwrite-drawing clip sid lane-id (random-uuid) (clip/fresh-id clip) at
(span/overwrite-drawing clip sid (random-uuid) (clip/fresh-id clip) at
{:extent (or extent :keep)
:remainder-id (random-uuid)})
{:refused "this lane's frames are not the open symbol's"})]
{:refused "the playhead is not on one frame of this symbol"})]
(committed db sid result [::overwrite-drawing :grow-symbol]))))
(rf/reg-event-db
::trim
(fn [db [_ edge]]
(let [{:keys [clip sid id at]} (at-playhead db)]
(apply-lane-command
(apply-command
db sid (if at (span/trim clip sid id edge at) no-frame) nil))))
(rf/reg-event-db
::move
(fn [db _]
(let [{:keys [clip sid id at]} (at-playhead db)]
(apply-lane-command
(apply-command
db sid (if at (span/move clip sid id at) no-frame) nil))))
(rf/reg-event-db
@ -333,10 +304,10 @@
(fn [db _]
(let [{:keys [clip sid node]} (at-playhead db)
span (node/placed-span node)]
(apply-lane-command
(apply-command
db sid (if (and span (every? integer? span))
(lane/blank clip sid (:parent node) span {})
{:refused "select a cel that starts and ends on whole lane frames"})
(span/blank clip sid span {})
{:refused "select a clip that starts and ends on whole frames"})
nil))))
(rf/reg-event-db
@ -344,21 +315,21 @@
(fn [db [_ deep?]]
(let [clip (:clip (store/entry (:clip/current db)))
[_ sid id] (get-in db [:ui :selection])]
(apply-lane-command db sid (lane/make-unique clip sid id {:deep? deep?}) nil))))
(apply-command db sid (span/make-unique clip sid id {:deep? deep?}) nil))))
(rf/reg-event-db
::extend-hold
(fn [db [_ delta extent]]
(let [clip (:clip (store/entry (:clip/current db)))
[_ sid id] (get-in db [:ui :selection])
result (lane/extend-hold clip sid id delta {:extent (or extent :keep)})]
(apply-lane-command db sid result [::extend-hold delta :grow-symbol]))))
result (span/extend-hold clip sid id delta {:extent (or extent :keep)})]
(apply-command db sid result [::extend-hold delta :grow-symbol]))))
(rf/reg-event-fx
::lane-retry
::retry
(fn [{:keys [db]} _]
(if-let [event (get-in db [:ui :lane-retry])]
{:db (update db :ui dissoc :lane-retry) :dispatch event}
(if-let [event (get-in db [:ui :retry])]
{:db (update db :ui dissoc :retry) :dispatch event}
{})))
@ -436,6 +407,19 @@
(= :instance (get-in clip [:symbols sid :nodes id :kind])) path
:else (vec (butlast path)))))
(defn aimed-symbol
"The symbol a command acts in and the path of rows down to it: `{:sid :path}`.
INSIDE the aimed instance, beside an aimed node of any other kind, the open
symbol when nothing is aimed — which is `where-new-goes`, resolved. There is
no lane to aim at any more: a lane is how a symbol is DRAWN, so what a gesture
names is a symbol, and whether that symbol is drawn as a lane is a separate
question `symbol/lane?` answers."
[clip st db frame]
(let [open (get-in db [:ui :open])
down (where-new-goes clip db)]
(assoc (nest/inside clip st open down frame) :path down)))
;; ---------------------------------------------------------------------------
;; drawing a polygon
;;
@ -456,10 +440,10 @@
(update-in db [:ui :draft] into [x y])
db)))
(defn into-the-lane
"Where a polygon drawn with a lane aimed goes: the path of the held clip the
lane exposes at the playhead, and the document containing it. `{:clip :path}`,
or `{:refused why}`.
(defn into-the-sequence
"Where a polygon drawn into a symbol DRAWN AS A LANE goes: the path of the held
clip that symbol exposes at the playhead, and the document containing it.
`{:clip :path}`, or `{:refused why}`.
A GAP IS NOT A REFUSAL, IT IS A NEW DRAWING. The frame under the playhead is
where the drawing belongs, so drawing on an empty frame makes the one-frame
@ -467,47 +451,46 @@
controls used to say.
`overwrite-drawing` rather than `append-drawing`, because a gap already has
the room. Appending RIPPLES everything after it later by the new cel's
the room. Appending RIPPLES everything after it later by the new clip's
duration — that is what `insert` means, and it is a different intention.
Placed into a gap, overwrite clears nothing and moves nobody.
A CEL'S PATH IS ONE STEP. `[cel]` and not `[lane cel]`: within one symbol the
rows are flat and a cel is not a row at all, which is the same addressing
`rows` hands the timeline and `trail` reads back."
[clip st db lane]
(let [open (get-in db [:ui :open])
lane-id (:id lane)
owner (:frame (nest/inside clip st open [] (get-in db [:playback :frame])))
at (when (number? owner) (lane/lane-frame clip open lane-id owner))
cel (when (integer? at)
THE CLIP'S PATH IS THE SYMBOL'S PATH PLUS ONE STEP, because a clip of a lane
is an ordinary row of the symbol holding it — which is the addressing `rows`
hands the timeline and `trail` reads back."
[clip db {:keys [sid frame path]}]
(let [exposed (when (integer? frame)
(some (fn [c] (let [[lo hi] (node/placed-span c)]
(when (and (<= lo at) (< at hi)) c)))
(symbol/lane-clips (get-in clip [:symbols open :nodes]) lane-id)))]
(when (and (<= lo frame) (< frame hi)) c)))
(symbol/children (get-in clip [:symbols sid :nodes]))))]
(cond
(not (integer? at))
{:refused "the playhead is not on one frame of this lane"}
cel {:clip clip :path [(:id cel)]}
(not (integer? frame))
{:refused "the playhead is not on one frame of this symbol"}
exposed {:clip clip :path (conj (vec path) (:id exposed))}
:else
(let [cel-id (random-uuid)
made (lane/overwrite-drawing clip open lane-id cel-id (clip/fresh-id clip) at
made (span/overwrite-drawing clip sid cel-id (clip/fresh-id clip) frame
{:extent :grow-symbol
:remainder-id (random-uuid)})]
(if (:refused made) made {:clip (:clip made) :path [cel-id]})))))
(if (:refused made) made {:clip (:clip made) :path (conj (vec path) cel-id)})))))
(defn polygon-landing
"Choose the document and row path a finished polygon is drawn into.
An aimed lane wins regardless of what is selected on the stage: an
occupied frame lands in its cel and a gap first becomes a one-frame drawing.
With no lane aimed, ordinary target-based drawing is unchanged."
WHERE IT GOES IS A SYMBOL, and what happens there follows how that symbol is
DRAWN: in one drawn as a lane an occupied frame lands in its clip and a gap
first becomes a one-frame drawing, because the sequence is what says which
drawing the playhead is on. In an ordinary composition the polygon goes
straight into the symbol, as it always did."
[clip st db]
(if-let [lane (aimed-lane clip db)]
(assoc (into-the-lane clip st db lane) :lane? true)
{:clip clip :path (where-new-goes clip db) :lane? false}))
(let [into (aimed-symbol clip st db (get-in db [:playback :frame]))]
(if (and (:sid into) (symbol/lane? (clip/symbol clip (:sid into))))
(assoc (into-the-sequence clip db into) :lane? true)
{:clip clip :path (:path into) :lane? false})))
(defn beginning-polygon
"Enter polygon mode, first materializing a drawing at the playhead when a
lane is aimed and that frame is empty.
"Enter polygon mode, first materializing a drawing at the playhead when the
symbol it lands in is drawn as a lane and that frame is empty.
Creating here, rather than when the polygon is finished, means the drawing is
already the current cel while points are being placed. Cancelling the polygon
@ -558,7 +541,7 @@
(nil? sid)
(update db :project merge
{:status (if (:lane? landing)
"this lane is not on screen at this frame"
"this sequence is not on screen at this frame"
"what you are drawing into is not on screen at this frame")})
;; `random-uuid` is the one impurity in this namespace, and it is here
;; rather than in `domain/paint` for the reason `clip/place-symbol` spells
@ -588,57 +571,61 @@
(declare record-auto-frame)
;; ---------------------------------------------------------------------------
;; a new symbol
;; a new symbol or lane
(defn- create-container
"Create and place one empty symbol. Lane creation is explicit: `lane?` marks
the new symbol for linear timeline display; ordinary symbol creation never
does. Both operations place the new symbol through the same span command, so
an explicitly aimed lane still applies its claim-time rule."
[db where lane?]
(let [{document :clip st :store} (store/entry (:clip/current db))
open (get-in db [:ui :open])
frame (get-in db [:playback :frame])
into (if (= :top where)
(assoc (nest/inside document st open [] frame) :path [])
(aimed-symbol document st db frame))
{host :sid at :frame down :path} into
sid (clip/fresh-id document)
instance-id (random-uuid)
end (clip/frames document host)
result (cond
(nil? host)
{:refused "what you are adding to is not on screen at this frame"}
(not (integer? at))
{:refused "the playhead is not on one frame of this symbol"}
(or (nil? end) (>= at end))
{:refused "the playhead is past the end of this symbol"}
:else
(let [new-symbol (cond-> {:id sid :name (name sid)
:fps (clip/fps document host)
:frames (- end at) :nodes {}}
lane? (assoc :display :lane))
seeded (assoc-in document [:symbols sid] new-symbol)]
(span/place-symbol seeded st host instance-id sid at
{:extent :grow-symbol
:remainder-id (random-uuid)})))]
(if-let [why (:refused result)]
(update db :project merge {:status why})
(let [selection [:node host instance-id (conj (vec down) instance-id)]]
(cond-> (-> db
(edit/transaction (constantly (:clip result)))
(assoc-in [:ui :selection] selection)
(update-in [:ui :expanded] (fnil into #{})
(rest (reductions conj [] down))))
lane? (assoc-in [:ui :target] (target-of selection)))))))
(rf/reg-event-db
::new-symbol
;; `where` is `:inside` — in whatever the target names — or `:top`, in the open
;; symbol regardless of it. A lane is the temporal form of this same operation:
;; inside it, a new empty symbol is a one-frame held clip at the playhead.
(fn [db [_ where]]
(let [{clip :clip st :store} (store/entry (:clip/current db))
target-lane (when (= :inside where) (aimed-lane clip db))
open (get-in db [:ui :open])
owner (:frame (nest/inside clip st open [] (get-in db [:playback :frame])))
at (when (and target-lane (number? owner))
(lane/lane-frame clip open (:id target-lane) owner))
drawing-id (clip/fresh-id clip)
cel-id (random-uuid)
down (if (= :top where) [] (where-new-goes clip db))
{host :sid frame :frame} (nest/inside clip st open down
(get-in db [:playback :frame]))
lane-id (random-uuid)]
(if target-lane
(let [result (if (integer? at)
(lane/overwrite-drawing clip open (:id target-lane) cel-id drawing-id at
{:extent :grow-symbol
:remainder-id (random-uuid)})
{:refused "the playhead is not on one frame of this lane"})]
(if-let [why (:refused result)]
(update db :project merge {:status why})
(-> db
(edit/transaction (constantly (:clip result)))
(assoc-in [:ui :selection] [:node open cel-id [cel-id]]))))
(if-not host
(update db :project merge
{:status "what you are adding to is not on screen at this frame"})
(let [free (empty-lane clip host)
lane-id (or free lane-id)
prepared (if free {:clip clip} (lane/add-lane clip host lane-id))
result (if (:refused prepared) prepared
(lane/overwrite-drawing (:clip prepared) host lane-id
cel-id drawing-id frame
{:extent :grow-symbol
:remainder-id (random-uuid)}))]
(if-let [why (:refused result)]
(update db :project merge {:status why})
(-> db
(edit/transaction (constantly (:clip result)))
(assoc-in [:ui :selection] [:node host cel-id (conj down cel-id)])
(assoc-in [:ui :target]
{:sid host :id lane-id :path (conj down lane-id)})
(update-in [:ui :expanded] (fnil into #{})
(rest (reductions conj [] down)))))))))))
(create-container db where false)))
(rf/reg-event-db
::new-lane
(fn [db _]
;; A lane is an explicit top-level track of the open symbol. It must not
;; become nested merely because the previously created lane is still aimed.
(create-container db :top true)))
;; ---------------------------------------------------------------------------
;; a drop in flight
@ -659,85 +646,74 @@
::drop-clear
(fn [db _] (update db :ui dissoc :drop)))
(defn lane-destination
"Where a drop lands: the lane it was aimed at, the selected one, or a new one.
(defn drop-destination
"Which symbol a drop lands in and on which of its frames: `{:clip :sid :at
:path}`, or `{:refused why}`.
EVERYTHING IN THE TIMELINE IS A LANE, so this is the one rule and every drop
asks it — a symbol from the pool, a sound, and a video brought in as a take
alike. It answers `{:clip :sid :lane-id :at :made?}` with the lane already
created in `:clip` when it had to make one, 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
into a symbol exactly where it names an instance, which is what `nest/inside`
already answers; with nothing under the pointer it is the open symbol. Nothing
is created to receive the drop: the symbol IS the container, so the first drop
into one is the same operation as the second.
`kind` is what is about to go in, `:picture` or `:sound`: a lane holds one or
the other, so an aimed lane that holds the other kind is not the destination
and a new one is made beside it."
[db document st frame target kind]
(let [open (get-in db [:ui :open])
selected (get-in db [:ui :selection])
[_ sel-sid sel-id] selected
holds (fn [[_ sid id]]
(let [nodes (get-in document [:symbols sid :nodes])]
(when (node/lane? (get nodes id))
(let [kinds (into #{} (map :kind) (symbol/lane-clips nodes id))]
(or (empty? kinds)
(= kinds #{(if (= :sound kind) :audio :instance)}))))))
;; With nothing aimed, an empty lane that is already there — see
;; `empty-lane` — and only then a new one.
free (when-let [id (empty-lane document open)]
(when (holds [:node open id]) [:node open id [id]]))
aimed (or (when (and target (holds target)) target)
(when (and (= :node (first selected)) (holds selected)) selected)
free)
[_ aimed-sid aimed-id aimed-path] aimed
sid (if aimed aimed-sid open)
lane-id (if aimed aimed-id (random-uuid))
prepared (if aimed {:clip document} (lane/add-lane document sid lane-id))
lane-sel [:node sid lane-id (if aimed aimed-path [lane-id])]
owner (when-not (:refused prepared)
(selection-frame (:clip prepared) st open lane-sel frame))
at (when (number? owner)
(lane/lane-frame (:clip prepared) sid lane-id owner))]
`: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]
(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)
:nodes (:id target) :kind]))
(vec (:path target))
:else (vec (butlast (:path target))))
{:keys [sid] at :frame} (nest/inside document st open path frame)]
(cond
(:refused prepared) prepared
(not (integer? at)) {:refused "the drop is not on one frame of this lane"}
:else {:clip (:clip prepared) :sid sid :lane-id lane-id :at at
:path (vec (butlast (nth lane-sel 3))) :made? (nil? aimed)})))
(nil? sid) {:refused "what you are dropping into is not on screen at this frame"}
(not (integer? at)) {:refused "the drop is not on one frame of that symbol"}
:else {:clip document :sid sid :at at :path path})))
(defn landed
"`db` after a drop that produced `result`, with `uuid` selected in `lane`."
[db {:keys [sid lane-id path made?]} uuid result]
"`db` after a drop that produced `result`, with `uuid` selected."
[db {:keys [sid path]} uuid result]
(if-let [why (:refused result)]
(-> db (update :ui dissoc :drop) (update :project merge {:status why}))
(cond-> (-> db
(update :ui dissoc :drop)
(edit/transaction (constantly (:clip result)))
(assoc-in [:ui :selection] [:node sid uuid (conj (vec path) uuid)]))
made? (assoc-in [:ui :target] {:sid sid :id lane-id :path [lane-id]}))))
(-> db
(update :ui dissoc :drop)
(edit/transaction (constantly (:clip result)))
(assoc-in [:ui :selection] [:node sid uuid (conj (vec path) uuid)]))))
(rf/reg-event-db
::drop-symbol
;; A symbol dropped on a lane becomes a naturally playing clip in that lane.
;; With no lane under it, make one: new timeline/stage placement therefore
;; never invents another permanent row-per-symbol track.
;; A symbol dropped on a row becomes a naturally playing clip in the symbol that
;; row leads into. Whether it claims the time it lands on is `span/place-symbol`'s
;; question and it answers it from the destination's display mode, so a drop onto
;; a lane trims its neighbour and a drop into a composition does not.
(fn [db [_ source-id frame point target]]
(let [{document :clip st :store} (store/entry (:clip/current db))
where (lane-destination db document st frame target :picture)
where (drop-destination db document st frame target)
uuid (random-uuid)]
(if (:refused where)
(-> db (update :ui dissoc :drop) (update :project merge {:status (:refused where)}))
(landed db where uuid
(lane/place-symbol (:clip where) st (:sid where) (:lane-id where)
(span/place-symbol (:clip where) st (:sid where)
uuid source-id (:at where)
{:extent :grow-symbol :point point
:remainder-id (random-uuid)}))))))
(rf/reg-event-db
::drop-sound
;; A SOUND IS A CLIP IN A LANE TOO. It is placed and then adopted rather than
;; written straight into the lane, so one command owns where a sound's frames
;; are — `clip/place-sound` — and one owns what claiming lane time means.
;; A SOUND IS A CLIP TOO. It is placed and then adopted rather than written
;; straight in, so one command owns where a sound's frames are —
;; `clip/place-sound` — and one owns what claiming time means.
(fn [db [_ {:keys [source label length rate]} frame target]]
(let [{document :clip st :store} (store/entry (:clip/current db))
where (lane-destination db document st frame target :sound)
where (drop-destination db document st frame target)
uuid (random-uuid)]
(if (:refused where)
(-> db (update :ui dissoc :drop) (update :project merge {:status (:refused where)}))
@ -747,31 +723,41 @@
(:rate (clip/grid-time (:clip where) sid)))
uuid)]
(landed db where uuid
(lane/adopt seeded sid (:lane-id where) uuid (:at where)
(span/adopt seeded sid uuid (:at where)
{:extent :grow-symbol :remainder-id (random-uuid)})))))))
(rf/reg-event-db
::adopt-in-lane
(fn [db [_ [_ from-sid id _] [_ lane-sid lane-id lane-path :as lane-selection]
frame]]
::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]]
(let [{document :clip st :store} (store/entry (:clip/current db))
open (get-in db [:ui :open])
owner-frame (selection-frame document st open lane-selection frame)
at (when (number? owner-frame)
(lane/lane-frame document lane-sid lane-id owner-frame))
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
(not= from-sid lane-sid)
{:refused "a clip and its destination lane must be in the same symbol"}
(not (integer? at)) {:refused "the drop is not on one frame of this lane"}
:else (lane/adopt document lane-sid lane-id id at
(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)
{:extent :grow-symbol
:remainder-id (random-uuid)}))
path (conj (vec (butlast lane-path)) id)]
:remainder-id (random-uuid)}))]
(if-let [why (:refused result)]
(update db :project merge {:status why})
(-> db
(edit/transaction (constantly (:clip result)))
(assoc-in [:ui :selection] [:node lane-sid id path]))))))
(assoc-in [:ui :selection]
[:node (:sid into) landed-id
(conj (vec target-path) landed-id)]))))))
;; ---------------------------------------------------------------------------
;; moving rows between symbols
@ -783,6 +769,48 @@
(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]]

2
frontend/src/arthur/subs/ui.cljs
View file

@ -13,7 +13,7 @@
(rf/reg-sub ::selection (fn [db _] (get-in db [:ui :selection])))
(rf/reg-sub ::target (fn [db _] (get-in db [:ui :target])))
(rf/reg-sub ::lane-retry (fn [db _] (get-in db [:ui :lane-retry])))
(rf/reg-sub ::retry (fn [db _] (get-in db [:ui :retry])))
(rf/reg-sub ::tone (fn [db _] (get-in db [:ui :tone])))
(rf/reg-sub ::tool (fn [db _] (get-in db [:ui :tool])))
(rf/reg-sub ::auto-key? (fn [db _] (boolean (get-in db [:ui :auto-key?]))))

3
frontend/src/arthur/ui/location.cljs
View file

@ -76,7 +76,8 @@
(map (fn [a]
(let [m (get nodes a)]
{:kind (:kind m)
:lane? (node/lane? m)
:lane? (and (= :instance (:kind m))
(symbol/lane? (clip/symbol clip (node/source m))))
:sid in :id a :of (node/source m)
:label (crumb-label clip a m)
:select [:node in a (conj so-far a)]})))

12
frontend/src/arthur/ui/params.cljs
View file

@ -14,6 +14,7 @@
[arthur.domain.paint :as paint]
[arthur.domain.params :as params]
[arthur.domain.pose :as pose]
[arthur.domain.symbol :as symbol]
[arthur.domain.trace :as trace]
[arthur.events.history :as history]
[arthur.events.paint :as paint-events]
@ -281,11 +282,10 @@
(defn- correction-section [[sid selected-id selected]]
(let [clip @(rf/subscribe [::render/clip])
parent (get-in clip [:symbols sid :nodes (:parent selected)])
targets (cond
(node/lane? selected) [selected-id]
(node/lane? parent) [selected-id (:id parent)]
:else [])]
lane-context? (or (symbol/lane? (clip-domain/symbol clip sid))
(and (= :instance (:kind selected))
(symbol/lane? (clip-domain/symbol clip (node/source selected)))))
targets (if lane-context? [selected-id] [])]
(when (seq targets)
(r/with-let [draft (r/atom (correction-initial clip sid selected-id))]
(let [target (:target @draft)
@ -303,7 +303,7 @@
(doall (for [[i id] (map-indexed vector targets)]
^{:key (str id)}
[:option {:value i}
(str (if (= id selected-id) "selected · " "lane · ") (brief id))]))]]
(str "selected · " (brief id))]))]]
[:label.inspector-field "property"
[:select {:value (if (= [:xform :rot] (:path @draft)) "rotation" "position")
:on-change #(swap! draft assoc :path

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

@ -171,6 +171,9 @@
(into (inside-rows sid child cpath (inc depth) cself cspan))))))
(walk [sid path depth ->open]
(let [sym (get-in clip [:symbols sid])
root-lane? (and (empty? path) (symbol/lane? sym))
root-clips (when root-lane? (symbol/children (:nodes sym)))
root-ids (into #{} (map :id) root-clips)
ordered (->> (:nodes sym)
;; Front-most at the top, as a layer list is drawn
;; everywhere. `:z` is the lexicographic draw key;
@ -179,8 +182,49 @@
reverse
;; Sounds are listed below the picture, by
;; `sound-rows`, wherever they are.
(remove #(= :audio (:kind (val %)))))]
(into []
(remove #(= :audio (:kind (val %))))
;; In an open lane symbol, its clips are blocks
;; on the symbol's own row. Span-less decoration
;; remains an ordinary row beside it.
(remove #(contains? root-ids (key %))))
root-row (when root-lane?
(let [open? (contains? expanded [::lane])
row {:path [::lane]
:depth depth
:label (or (:name sym) (name sid))
:kind :symbol
:lane? true
:select [:node sid nil []]
:expandable? true
:expanded? open?
:span [0 (:frames sym)]
:keys []
:cels (mapv (fn [child]
{:id (:id child)
:label (or (get-in clip [:symbols (node/source child) :name])
(some-> (node/source child) name)
(node-label (:id child) child))
:source (node/source child)
:span (mapv ->open (node/placed-span child))
:keys (into []
(comp (mapcat keyed-frames)
(map (comp ->open (local->parent child)))
(distinct))
(vals (node/channels child)))
:select [:node sid (:id child)
(conj path (:id child))]})
root-clips)}]
(cond-> [row]
open?
(into (if-let [child (first (filter #(under? (conj path (:id %)))
root-clips))]
(portal sid path (inc depth) ->open child)
[{:path [::lane ::portal]
:depth (inc depth) :kind :hint
:label (if (seq root-clips)
"select a clip to inspect"
"empty lane")}])))))]
(into (vec root-row)
(mapcat
(fn [[id n]]
(let [rpath (conj path id)
@ -197,6 +241,10 @@
(map #(local->parent (get-in sym [:nodes %]))
(reverse ancestors)))
self (comp parent-map (local->parent n))
source-sym (when (= :instance (:kind n))
(clip/symbol clip (node/source n)))
lane? (symbol/lane? source-sym)
clips (when lane? (symbol/children (:nodes source-sym)))
span (mapv parent-map
(or (node/placed-span
(cond-> n
@ -208,7 +256,7 @@
:label (node-label id n)
:kind :node
:node-kind (:kind n)
:lane? (node/lane? n)
:lane? lane?
:of (node/source n)
:select [:node sid id rpath]
:expandable? true
@ -219,16 +267,7 @@
(distinct))
(vals channels))
:dense? (boolean (some :dense (vals channels)))}]
;; A CLIP IS NOT A ROW. A lane's symbol clips are
;; blocks on the lane's own row, so twelve clips are
;; still one row. The clip remains independently
;; selectable and addressable; only its presentation
;; is shared.
(if (node/lane? (get-in sym [:nodes (:parent n)]))
[]
(let [clips (when (node/lane? n)
(symbol/lane-clips (:nodes sym) id))
;; A lane of sounds is a lane like any other —
(let [;; A lane of sounds is a lane like any other —
;; same blocks, same edges, same portal — and
;; is listed under the audio heading because
;; that is where somebody looks for a sound,
@ -236,7 +275,7 @@
sound-lane? (and (seq clips)
(every? #(= :audio (:kind %)) clips))
row (cond-> row
(node/lane? n)
lane?
(assoc :cels
(mapv (fn [child]
{:id (:id child)
@ -252,24 +291,26 @@
(map (comp self (local->parent child)))
(distinct))
(vals (node/channels child)))
:select [:node sid (:id child) (conj path (:id child))]})
:select [:node (node/source n) (:id child)
(conj rpath (:id child))]})
clips)))]
(cond->> (if-not open?
[row]
(-> [row]
(into (channel-rows n rpath (inc depth) self span))
;; The one clip an expanded lane opens.
(into (when (node/lane? n)
(if-let [child (first (filter #(under? (conj path (:id %))) clips))]
(portal sid path (inc depth) self child)
(into (when lane?
(if-let [child (first (filter #(under? (conj rpath (:id %))) clips))]
(portal (node/source n) rpath (inc depth) self child)
[{:path (conj rpath ::portal)
:depth (inc depth)
:kind :hint
:label (if (seq clips)
"select a clip to inspect"
"empty lane")}])))
(into (inside-rows sid n rpath (inc depth) self span))))
sound-lane? (mapv #(assoc % :sound? true)))))))
(into (when-not lane?
(inside-rows sid n rpath (inc depth) self span)))))
sound-lane? (mapv #(assoc % :sound? true))))))
ordered))))]
(if (get-in clip [:symbols sid])
(walk sid [] 0 #(/ % (:rate (clip/grid-time clip sid))))
@ -279,19 +320,14 @@
"Audio rows use the same flattened intervals as the mixer, including source
in-points, cel speeds, parent timing, and silence beneath visual holds.
WHAT IS IN A LANE OF THIS SYMBOL IS NOT FLATTENED HERE. A sound in a lane is
WHAT IS IN A LANE SYMBOL IS NOT FLATTENED HERE. A sound in a lane is
a clip somebody placed and can move, trim and open, and `rows` draws it as
one; flattening it as well would show the same sound on two rows, only one of
which could be edited. What remains is what this view is for: audio nested
inside the symbols this one places, mapped into this ruler."
[clip sid expanded]
(if-not (get-in clip [:symbols sid]) []
(let [nodes (get-in clip [:symbols sid :nodes])
in-lane (into #{} (keep (fn [[id n]]
(when (and (= :audio (:kind n))
(node/lane? (get nodes (:parent n))))
id)))
nodes)]
(let [lane? (symbol/lane? (clip/symbol clip sid))]
(vec
(mapcat
(fn [[path tracks]]
@ -314,8 +350,7 @@
(when open? (channel-rows n path 1 identity span)))))
(sort-by (comp str key)
(group-by :path
(remove #(and (= 1 (count (:path %)))
(contains? in-lane (first (:path %))))
(remove #(and lane? (= 1 (count (:path %))))
(nest/audio-tracks clip sid)))))))))
;; ---------------------------------------------------------------------------
@ -451,9 +486,9 @@
[:span.spacer]
;; After the spacer, both of them: an offer that appears and a reading that
;; comes and goes must not shove the fixed controls sideways when they do.
(when @(rf/subscribe [::sub/lane-retry])
(when @(rf/subscribe [::sub/retry])
[:button.retry {:title "the command was refused because the shot is too short"
:on-click (act [::ui/lane-retry])} "extend shot and apply"])
:on-click (act [::ui/retry])} "extend shot and apply"])
;; Measured in the loop, not derived from the clock — the whole question
;; while profiling is whether the painting keeps up with the clock, and a
;; number computed FROM the clock would answer itself. Shown only while it

32
frontend/test/arthur/domain/correction_test.cljs
View file

@ -4,22 +4,22 @@
[arthur.domain.clip :as clip]
[arthur.domain.correction :as correction]
[arthur.domain.leaf :as leaf]
[arthur.domain.lane-test :as fixture]))
[arthur.domain.sequence-test :as fixture]))
(defn- channel [doc id path]
(get-in doc [:symbols :main :nodes id :channels path]))
(deftest authors-the-three-motions-as-ordinary-layer-channels
(let [doc (fixture/document)
constant (correction/add doc :main :girl [:xform :rot]
constant (correction/add doc :main :a [:xform :rot]
{:id :flat :support [2 5] :motion :constant :delta 1})
ramp (correction/add (:clip constant) :main :girl [:xform :rot]
ramp (correction/add (:clip constant) :main :a [:xform :rot]
{:id :ramp :support [6 9] :motion :ramp :start 0 :end 2})
returned (correction/add (:clip ramp) :main :girl [:xform :rot]
returned (correction/add (:clip ramp) :main :a [:xform :rot]
{:id :return :support [9 12] :motion :return
:start 0 :peak 3 :peak-frame 10})
c (channel (:clip returned) :girl [:xform :rot])]
(is (= :girl (:selection returned)))
c (channel (:clip returned) :a [:xform :rot])]
(is (= :a (:selection returned)))
(is (= [:flat :ramp :return] (mapv :id (:over c))))
(is (= [0 0 1 1 1 0 0 1 2 0 3 0]
(mapv #(ch/value-at c % nil) (range 12))))
@ -47,19 +47,19 @@
put3 (ch/layer :put3 [0 2] :replace (ch/framed [1 2 3]))
add3 (ch/layer :add3 [0 2] :offset (ch/framed [1 1 1]))
stacked (assoc base :over [put3 add3])
doc (assoc-in doc [:symbols :main :nodes :girl :channels [:xform :pos]] stacked)]
(is (:refused (correction/remove-layer doc :main :girl [:xform :pos] :put3))
doc (assoc-in doc [:symbols :main :nodes :a :channels [:xform :pos]] stacked)]
(is (:refused (correction/remove-layer doc :main :a [:xform :pos] :put3))
"removing the replacement would expose a wrong-shaped base")
(let [conflicted (assoc-in doc [:symbols :main :nodes :girl :channels [:xform :pos] :over 1 :conflict]
(let [conflicted (assoc-in doc [:symbols :main :nodes :a :channels [:xform :pos] :over 1 :conflict]
"old topology")
retried (correction/retry-layer conflicted :main :girl [:xform :pos] :add3)]
retried (correction/retry-layer conflicted :main :a [:xform :pos] :add3)]
(is (:clip retried))
(is (nil? (get-in (:clip retried)
[:symbols :main :nodes :girl :channels [:xform :pos] :over 1 :conflict]))))
[:symbols :main :nodes :a :channels [:xform :pos] :over 1 :conflict]))))
(let [without-replacement (-> doc
(assoc-in [:symbols :main :nodes :girl :channels [:xform :pos] :over]
(assoc-in [:symbols :main :nodes :a :channels [:xform :pos] :over]
[(assoc add3 :conflict "old topology")]))]
(is (:refused (correction/retry-layer without-replacement :main :girl
(is (:refused (correction/retry-layer without-replacement :main :a
[:xform :pos] :add3))
"retry refuses when the current effective base still has the wrong shape"))))
@ -74,13 +74,13 @@
(deftest corrections-round-trip-with-identity-support-and-order
(let [doc (fixture/document)
one (:clip (correction/add doc :main :girl [:xform :rot]
one (:clip (correction/add doc :main :a [:xform :rot]
{:id :one :support [0 3] :motion :constant :delta 1}))
two (:clip (correction/add one :main :girl [:xform :rot]
two (:clip (correction/add one :main :a [:xform :rot]
{:id :two :support [3 6] :motion :ramp
:start 0 :end 2}))
back (leaf/clip "u" (leaf/leaves "u" two))]
(is (= two back))
(is (= [:one :two]
(mapv :id (get-in back [:symbols :main :nodes :girl
(mapv :id (get-in back [:symbols :main :nodes :a
:channels [:xform :rot] :over]))))))

6
frontend/test/arthur/domain/instance_test.cljs
View file

@ -241,11 +241,9 @@
made (clip/new-symbol c :outer id 20 u)]
(is (= :symbol-1 id))
(is (= :symbol-2 (clip/fresh-id made)) "the next one does not collide")
(is (= {:id :symbol-1 :name "symbol-1" :fps 30 :frames 180
:nodes {:lane clip/lane-node}}
(is (= {:id :symbol-1 :name "symbol-1" :fps 30 :frames 180 :nodes {}}
(clip/symbol made :symbol-1))
"empty but for the lane every symbol is born with, and as long as the
rest of what it was placed in")
"empty, ordinary, and as long as the rest of what it was placed in")
(is (= {:span [0 180] :time {:mode :map :at 20 :rate 1}}
(select-keys (get-in made [:symbols :outer :nodes u]) [:span :time])))
(is (= #{:symbol-1} (node/sources (get-in made [:symbols :outer :nodes u])))

650
frontend/test/arthur/domain/lane_test.cljs
View file

@ -1,650 +0,0 @@
(ns arthur.domain.lane-test
(:require [cljs.test :refer [deftest is testing]]
[arthur.domain.bring :as bring]
[arthur.domain.channel :as ch]
[arthur.domain.clip :as clip]
[arthur.domain.history :as history]
[arthur.domain.leaf :as leaf]
[arthur.domain.nest :as nest]
[arthur.domain.node :as node]
[arthur.domain.palette :as pal]
[arthur.domain.pick :as pick]
[arthur.domain.lane :as lane]
[arthur.domain.span :as span]
[arthur.domain.symbol :as symbol]))
(defn drawing [id x frames]
{:id id :frames frames
:nodes {:mark {:id :mark :kind :rect :z "a"
:channels {[:geom :size] (ch/framed 4)
[:xform :pos] (ch/framed [x 0])}}}})
(defn cel [id source at duration speed]
{:id id :kind :instance :parent :girl :z (name id)
:source {:symbol source} :playback {:in 0 :speed speed :end :stop}
:time {:at at :rate 1} :span [0 duration]})
(defn document []
(let [a (cel :a :drawing-a 0 4 0)
b (assoc-in (cel :b :drawing-b 4 4 0)
[:channels [:xform :pos]] (ch/keyed {0 [0 0] 1 [2 0]} :hold))
insert (assoc-in (cel :insert :wave 8 4 1) [:playback :in] 3)]
{:name "cels" :fps 24 :width 320 :height 200
:symbols
{:main {:id :main :frames 12
:nodes {:girl {:id :girl :kind :group :layout :sequence :z "b"
:channels {[:xform :pos] (ch/keyed {0 [0 0] 6 [60 0] 12 [0 0]} :linear)}}
:a a :b b :insert insert
:plate {:id :plate :kind :rect :z "a"
:channels {[:geom :size] (ch/framed 10)
[:xform :pos] (ch/keyed {0 [-40 0] 11 [70 0]} :linear)}}}}
:drawing-a (drawing :drawing-a 10 1)
:drawing-b (drawing :drawing-b 20 1)
:wave (assoc-in (drawing :wave 0 10) [:nodes :mark :channels [:xform :pos]]
(ch/keyed {0 [0 0] 9 [900 0]} :linear))}}))
(defn sample [doc fs]
(let [r (clip/resolver doc :main nil pal/index-of nil)]
(into {} (map (fn [f] [f (into {} (map (juxt :node :cx)) (r f))])) fs)))
(deftest one-lane-mixes-held-drawings-and-playing-content
(let [doc (document) at (sample doc (range 12))]
(is (empty? (clip/problems doc)))
(is (= 40 (get-in at [3 [:a :mark]])))
(is (= 60 (get-in at [4 [:b :mark]])))
(is (= 72 (get-in at [5 [:b :mark]])))
(is (= 340 (get-in at [8 [:insert :mark]])))
(is (= 610 (get-in at [11 [:insert :mark]])))
(is (= (zipmap (range 12) (range -40 80 10))
(into {} (map (fn [[f ops]] [f (js/Math.round (:plate ops))])) at)))
(is (nil? (get-in at [4 [:a :mark]])) "half-open cuts have a single owner")))
(deftest cel-ripple-keeps-lane-keys-and-moves-cel-corrections
(let [doc (document)
result (lane/extend-hold doc :main :a 2 {:extent :grow-symbol})
after (:clip result)
nodes (get-in after [:symbols :main :nodes])]
(is (= :a (:selection result)))
(is (= 14 (get-in after [:symbols :main :frames])))
(is (= [0 6] (node/placed-span (:a nodes))))
(is (= [6 10] (node/placed-span (:b nodes))))
(is (= [10 14] (node/placed-span (:insert nodes))))
(doseq [id [:girl :a :b :insert :plate]]
(is (= (get-in doc [:symbols :main :nodes id :channels]) (:channels (nodes id))))
(is (= (get-in doc [:symbols :main :nodes id :playback]) (:playback (nodes id)))))
(let [at (sample after [5 6 7 10])]
(is (= 60 (get-in at [5 [:a :mark]])))
(is (= 80 (get-in at [6 [:b :mark]])))
(is (= 72 (get-in at [7 [:b :mark]])) "B's correction follows B")
(is (= 320 (get-in at [10 [:insert :mark]])) "insert starts on source frame 3"))
(is (empty? (clip/problems after)))
(is (= (assoc-in doc [:symbols :main :frames] 14)
(:clip (lane/extend-hold after :main :a -2 {})))
"shrinking restores content, except the explicitly grown shot")))
(deftest overflow-and-invalid-edits-are-atomic
(let [doc (document)
result (lane/extend-hold doc :main :a 2 {})]
(is (:refused result))
(is (= 14 (:required-frames result)))
(is (not (contains? result :clip)))
(doseq [delta [0 -4 0.5 js/NaN]]
(is (:refused (lane/extend-hold doc :main :a delta {}))))
(is (:refused (lane/extend-hold doc :main :insert 1 {})))
(is (:refused (lane/extend-hold doc :main :missing 1 {})))))
(deftest dragging-a-cel-edge-trims-neighbours-or-ripples-them
(let [doc (document)
plain (:clip (lane/resize-out doc :main :a 6 {}))
across (:clip (lane/resize-out doc :main :a 9 {}))
ripple (:clip (lane/resize-out doc :main :a 6 {:ripple? true
:extent :grow-symbol}))
shrink (:clip (lane/resize-out doc :main :a 2 {:ripple? true}))]
(is (= [[0 6] [6 8] [8 12]]
(mapv node/placed-span (symbol/lane-clips (get-in plain [:symbols :main :nodes]) :girl)))
"a normal grow eats the beginning of the adjacent cel")
(is (= [[0 9] [9 12]]
(mapv node/placed-span (symbol/lane-clips (get-in across [:symbols :main :nodes]) :girl)))
"a long grow removes wholly consumed cels and trims the survivor")
(is (= [[0 6] [6 10] [10 14]]
(mapv node/placed-span (symbol/lane-clips (get-in ripple [:symbols :main :nodes]) :girl)))
"shift-grow moves every later cel")
(is (= [[0 2] [2 6] [6 10]]
(mapv node/placed-span (symbol/lane-clips (get-in shrink [:symbols :main :nodes]) :girl)))
"shift-shrink pulls every later cel left")
(is (:refused (lane/resize-out doc :main :a 0 {})))
(is (:refused (lane/resize-out doc :main :a 2.5 {})))))
(deftest the-middle-of-a-cut-rolls-both-edges
(let [doc (document)
rolled (:clip (lane/roll doc :main :a :b 6))
right-only (:clip (lane/resize-in doc :main :b 6))
grown-left (:clip (lane/resize-in doc :main :b 2))]
(is (= [[0 6] [6 8] [8 12]]
(mapv node/placed-span (symbol/lane-clips (get-in rolled [:symbols :main :nodes]) :girl)))
"the shared cut moves without moving either clip")
(is (= [[0 4] [6 8] [8 12]]
(mapv node/placed-span (symbol/lane-clips (get-in right-only [:symbols :main :nodes]) :girl)))
"the right side of the junction trims only the right clip")
(is (= [[0 2] [2 8] [8 12]]
(mapv node/placed-span (symbol/lane-clips (get-in grown-left [:symbols :main :nodes]) :girl)))
"growing the right clip left trims the neighbour instead of overlapping")
(is (:refused (lane/roll doc :main :a :b 0)))
(is (:refused (lane/roll doc :main :a :insert 6)))))
(deftest a-gap-is-an-uncovered-interval
(let [doc (update-in (document) [:symbols :main :nodes] dissoc :b)
at (sample doc [3 4 7 8])]
(is (= #{:plate} (set (keys (at 4)))))
(is (= #{:plate} (set (keys (at 7)))))
(is (get-in at [8 [:insert :mark]]))
(is (empty? (clip/problems doc)))))
(deftest validation-rejects-overlap-but-allows-empty-lanes
(is (some #(re-find #"overlap" %)
(clip/problems (assoc-in (document) [:symbols :main :nodes :b :time :at] 3))))
(is (empty? (clip/problems
(update-in (document) [:symbols :main :nodes] dissoc :a :b :insert))))
(is (seq (clip/problems
(assoc-in (document) [:symbols :main :nodes :a :span] [0 ##Inf]))))
(is (seq (clip/problems
(assoc-in (document) [:symbols :main :nodes :a :playback :speed] -1))))
(is (seq (node/problems {:id :old :kind :instance :z "a"
:channels {[:source] (ch/framed {:of :wave :in 0})}}))
"the obsolete format is rejected"))
(deftest playback-is-independent-of-property-channel-shape
(let [doc (document)
n (get-in doc [:symbols :main :nodes :a])
keyed (node/toggle-key n [:xform :rot] 0 nil)
unkeyed (node/toggle-key keyed [:xform :rot] 0 nil)]
(doseq [n [n keyed unkeyed]]
(is (= {:symbol :drawing-a :frame 0} (node/placed-frame n 11 1))))
(let [n (get-in doc [:symbols :main :nodes :insert])]
(is (= {:symbol :wave :frame 5} (node/placed-frame n 2 10)))
(is (nil? (node/placed-frame n 7 10)))
(is (= 9 (:frame (node/placed-frame (assoc-in n [:playback :end] :hold) 9 10))))
(is (= 2 (:frame (node/placed-frame (assoc-in n [:playback :end] :loop) 9 10)))))))
(deftest navigation-and-hit-testing-use-the-same-source-time
(let [doc (document)
n (get-in doc [:symbols :main :nodes :insert])]
(is (= 5 (:frame (nest/inside doc nil :main [:insert] 10))))
(is (= {:at 5 :rate 1} (:time (nest/inside doc nil :main [:insert] 10))))
(is (= 0 (:frame (nest/inside doc nil :main [:a] 3))))
(is (nil? (:time (nest/inside doc nil :main [:a] 3))))
(is (nil? (nest/inside doc nil :main [:a] 4)))
(is (= ((pick/bounds-of doc nil :main n) 2)
((pick/bounds-of doc nil :main (assoc-in n [:playback :in] 5)) 0)))))
(deftest seeking-and-source-reuse-do-not-share-cursors
(let [doc (assoc-in (document) [:symbols :main :nodes :b :source :symbol] :drawing-a)
fs [11 0 5 3 8 4 10 1 6 2 9 7]
at (sample doc fs)]
(is (= at (sample doc (reverse fs))))
(is (= at (sample doc (range 12))))
(let [edited (assoc-in doc [:symbols :drawing-a :nodes :mark :channels [:xform :pos]]
(ch/framed [99 0]))]
(is (= 99 (get-in (sample edited [0 4]) [0 [:a :mark]])))
(is (= 139 (get-in (sample edited [0 4]) [4 [:b :mark]]))))))
(deftest cel-identities-and-playback-round-trip
(let [doc (:clip (lane/extend-hold (document) :main :a 2 {:extent :grow-symbol}))
leaves (leaf/leaves :project doc)]
(is (= doc (leaf/clip :project leaves)))
(is (contains? leaves "clip/project/symbol/main/node/a"))
(is (not (contains? leaves "clip/project/symbol/main/channel/girl/source")))
(let [{copied :clip ids :ids}
(bring/symbols (assoc-in (clip/blank) [:symbols :drawing-a] (drawing :drawing-a 99 1))
doc [:main] {})]
(is (= :drawing-a-2 (:drawing-a ids)))
(is (= #{:drawing-a-2 :drawing-b :wave} (clip/places copied (:main ids))))
(is (empty? (clip/problems copied))))))
(deftest one-transaction-undoes-the-ripple-and-shot-extension
(let [doc (document)
after (:clip (lane/extend-hold doc :main :a 2 {:extent :grow-symbol}))
before-leaves (leaf/leaves :p doc)
after-leaves (leaf/leaves :p after)
h (-> nil history/hold (history/record before-leaves after-leaves 0) history/settle)
undo (history/undo h after-leaves)
redo (history/redo (:history undo) (:leaves undo))]
(is (= 1 (count (:done h))))
(is (= before-leaves (:leaves undo)))
(is (= after-leaves (:leaves redo)))))
(deftest create-lane-and-append-drawings
(let [doc (:clip (lane/add-lane (clip/blank) :main :girl))
a (:clip (lane/append-drawing doc :main :girl :a :drawing-a {}))
b (:clip (lane/append-drawing a :main :girl :b :drawing-b {}))]
(is (empty? (clip/problems b)))
(is (= [1 2] (node/placed-span (get-in b [:symbols :main :nodes :b]))))
(is (= 0 (get-in b [:symbols :main :nodes :b :playback :speed])))
(is (:refused (lane/append-drawing b :main :girl :a :new {})))))
(deftest arbitrary-symbols-drop-into-the-same-lane-and-claim-their-time
(let [doc (document)
dropped (lane/place-symbol doc nil :main :girl :clip :wave 2
{:extent :grow-symbol :remainder-id :tail})
after (:clip dropped)
clips (symbol/lane-clips (get-in after [:symbols :main :nodes]) :girl)]
(is (= :clip (:selection dropped)))
(is (= [[0 2] [2 12]] (mapv node/placed-span clips))
"the natural ten-frame symbol claims [2,12), trimming/removing incumbents")
(is (= :wave (node/source (second clips))))
(is (= 1 (:speed (node/playback-of (second clips))))
"a dropped symbol plays; it is not converted into a drawing hold")
(is (empty? (clip/problems after)))))
(deftest an-existing-symbol-row-can-be-adopted-by-a-lane
(let [doc (assoc-in (document) [:symbols :main :nodes :badge]
{:id :badge :kind :instance :z "z"
:source {:symbol :wave} :span [0 3]
:time {:at 1 :rate 1}
:playback {:in 2 :speed 1 :end :stop}})
result (lane/adopt doc :main :girl :badge 5
{:extent :grow-symbol :remainder-id :tail})
after (:clip result)
n (get-in after [:symbols :main :nodes :badge])]
(is (= :girl (:parent n)))
(is (= [5 8] (node/placed-span n)))
(is (= {:in 2 :speed 1 :end :stop} (:playback n))
"adoption changes placement, not source timing")
(is (= [[0 4] [4 5] [5 8] [8 12]]
(mapv node/placed-span
(symbol/lane-clips (get-in after [:symbols :main :nodes]) :girl))))
(is (empty? (clip/problems after)))))
(deftest fractional-placement-rates-convert-the-hold-delta
(let [doc (-> (document)
(assoc-in [:symbols :main :nodes :a :time :rate] 2)
(assoc-in [:symbols :main :nodes :a :span] [0 8]))
after (:clip (lane/extend-hold doc :main :a 2 {:extent :grow-symbol}))]
(is (= [0 12] (get-in after [:symbols :main :nodes :a :span])))
(is (= [6 10] (node/placed-span (get-in after [:symbols :main :nodes :b]))))))
(deftest bare-shapes-agree-in-reference-and-playback
(let [sym (drawing :bare 12 1)]
(is (= (symbol/eval-frame sym 0 nil pal/index-of nil)
((symbol/resolver sym nil pal/index-of nil) 0))
"omitted style colour must not crash a missing cursor")))
(deftest audio-follows-only-the-playing-cel
(let [voice {:id :voice :kind :audio :z "a" :source {:sound "voice"}
:span [0 10]
:channels {[:audio :gain] (ch/keyed {0 0 5 1} :linear)}}
doc (-> (document)
(assoc-in [:symbols :wave :nodes :voice] voice)
(assoc-in [:symbols :drawing-a :nodes :voice] voice))
[track :as tracks] (nest/audio-tracks doc :main)]
(is (= 1 (count tracks)) "the frozen drawing contributes no audio")
(is (= [8 12] (node/placed-span track)))
(is (= [3 7] (:span track)) "the source in-point trims the audio too")
(is (= {5 0 10 1} (get-in track [:channels [:audio :gain] :keys])))
(let [moved (:clip (lane/extend-hold doc :main :a 2 {:extent :grow-symbol}))
[track] (nest/audio-tracks moved :main)]
(is (= [10 14] (node/placed-span track)))
(is (= [3 7] (:span track))))
(let [fast (-> doc
(assoc-in [:symbols :main :nodes :girl :time] {:at 2 :rate 2})
(assoc-in [:symbols :main :nodes :insert :playback :speed] 2))
[track] (nest/audio-tracks fast :main)]
(is (= [6 7.75] (node/placed-span track)))
(is (= [3 10] (:span track)))
(is (= 4 (get-in track [:time :rate]))))))
(deftest a-looped-insert-schedules-distinct-audio-intervals
(let [doc (-> (document)
(assoc-in [:symbols :wave :frames] 4)
(assoc-in [:symbols :wave :nodes :voice]
{:id :voice :kind :audio :z "a" :source {:sound "v"} :span [1 3]})
(assoc-in [:symbols :main :nodes :insert :playback]
{:in 3 :speed 1 :end :loop}))]
(is (= [[10 12]] (mapv node/placed-span (nest/audio-tracks doc :main))))))
(deftest enclosing-retiming-is-respected-when-extending-the-shot
(let [doc (assoc-in (document) [:symbols :main :nodes :girl :time] {:at 8 :rate 2})
result (lane/extend-hold doc :main :a 2 {})]
(is (= 15 (:required-frames result)))
(is (nil? (:clip result)))
(is (= 15 (get-in (lane/extend-hold doc :main :a 2 {:extent :grow-symbol})
[:clip :symbols :main :frames])))))
(deftest reuse-shares-content-and-make-unique-decouples-one-cel
(let [doc (document)
shared (:clip (lane/reuse-drawing doc :main :girl :c :drawing-a
{:extent :grow-symbol}))
edit (fn [c sym x]
(assoc-in c [:symbols sym :nodes :mark :channels [:xform :pos]]
(ch/framed [x 0])))]
(is (:refused (lane/reuse-drawing doc :main :girl :c :drawing-a {}))
"the shot has to be extended on purpose")
(is (= :drawing-a (node/source (get-in shared [:symbols :main :nodes :c]))))
(is (= [12 13] (node/placed-span (get-in shared [:symbols :main :nodes :c]))))
(is (empty? (clip/problems shared)))
;; One drawing, two cels: the edit arrives at both.
(let [at (sample (edit shared :drawing-a 99) [0 12])]
(is (= 99 (get-in at [0 [:a :mark]])))
(is (= 99 (get-in at [12 [:c :mark]]))))
(let [unique (:clip (lane/make-unique shared :main :c {}))]
(is (= :drawing-a-2 (node/source (get-in unique [:symbols :main :nodes :c]))))
(is (= (:nodes (get-in shared [:symbols :drawing-a]))
(:nodes (get-in unique [:symbols :drawing-a-2])))
"a copy of the same drawing, not an empty one")
(is (= :drawing-a (node/source (get-in unique [:symbols :main :nodes :a])))
"the other cel keeps the original")
(let [at (sample (edit unique :drawing-a 99) [0 12])]
(is (= 99 (get-in at [0 [:a :mark]])))
(is (= 10 (get-in at [12 [:c :mark]])) "the cel made unique is untouched"))
(let [at (sample (edit unique :drawing-a-2 99) [0 12])]
(is (= 10 (get-in at [0 [:a :mark]])) "and does not reach back"))
(is (empty? (clip/problems unique))))
;; Nothing else places drawing-b, so there is nothing to decouple from.
(is (:refused (lane/make-unique doc :main :b {})))
(is (:refused (lane/make-unique doc :main :girl {}))
"a lane places nothing itself")))
(deftest duplicate-copies-the-drawing-and-not-the-cel
(let [doc (document)
made (:clip (lane/duplicate-drawing doc :main :b :d {:extent :grow-symbol}))
n (get-in made [:symbols :main :nodes :d])]
(is (= :drawing-b-2 (node/source n)))
(is (= (:nodes (get-in doc [:symbols :drawing-b]))
(:nodes (get-in made [:symbols :drawing-b-2]))))
(is (= [12 13] (node/placed-span n)))
(is (= {:in 0 :speed 0 :end :stop} (:playback n)))
(is (nil? (:channels n)) "B's own position correction belongs to B's cel")
(is (= (get-in doc [:symbols :main :nodes :b])
(get-in made [:symbols :main :nodes :b]))
"the drawing duplicated is left as it was")
(is (empty? (clip/problems made)))))
(deftest a-shallow-copy-keeps-its-parts-and-a-deep-copy-owns-them
;; A drawing assembled from another symbol: copying it shallowly must keep
;; using that part, and only an explicit deep copy may promise independence.
(let [doc (assoc-in (document) [:symbols :drawing-a :nodes :part]
{:id :part :kind :instance :z "b" :span [0 1]
:time {:at 0 :rate 1} :source {:symbol :wave}
:playback {:in 0 :speed 0 :end :stop}})
copy (fn [opts] (:clip (lane/duplicate-drawing
doc :main :a :d (merge {:extent :grow-symbol} opts))))
shallow (copy {})
deep (copy {:deep? true})]
(is (= :wave (node/source (get-in shallow [:symbols :drawing-a-2 :nodes :part]))))
(is (nil? (get-in shallow [:symbols :wave-2])))
(is (= :wave-2 (node/source (get-in deep [:symbols :drawing-a-2 :nodes :part]))))
(is (= (:nodes (get-in doc [:symbols :wave])) (:nodes (get-in deep [:symbols :wave-2]))))
(is (empty? (clip/problems shallow)))
(is (empty? (clip/problems deep)))))
(deftest reuse-refuses-what-would-not-be-a-document
(let [doc (document)]
(is (:refused (lane/reuse-drawing doc :main :girl :c :nothing-here {})))
(is (:refused (lane/reuse-drawing doc :main :girl :c :main {:extent :grow-symbol}))
"a symbol cannot go inside itself")
(is (:refused (lane/reuse-drawing doc :main :girl :a :drawing-a {:extent :grow-symbol}))
"a cel ID in use is not free")
(is (:refused (lane/reuse-drawing doc :main :plate :c :drawing-a {})))
(is (:refused (lane/duplicate-drawing doc :main :girl :d {})))))
(deftest drawing-on-twos-does-not-quantize-the-lane-transform
;; Cel length IS the drawing cadence, and it is the only thing on twos
;; here: the lane's transform has its own clock and keeps moving every frame.
;; Stepping it would be the cel cadence leaking into continuous motion.
(let [cel (fn [id source at] (cel id source at 2 0))
doc (-> (document)
(update-in [:symbols :main :nodes] dissoc :a :b :insert)
(update-in [:symbols :main :nodes] merge
{:c0 (cel :c0 :drawing-a 0)
:c1 (cel :c1 :drawing-b 2)
:c2 (cel :c2 :drawing-a 4)}))
xs {:c0 10 :c1 20 :c2 10}
at (sample doc (range 6))
showing (fn [f] (first (dissoc (at f) :plate)))]
(is (empty? (clip/problems doc)))
(is (= [:c0 :c0 :c1 :c1 :c2 :c2] (mapv #(first (key (showing %))) (range 6)))
"the drawing showing changes every second frame")
(is (= [0 10 20 30 40 50]
(mapv (fn [f] (let [[[id _] cx] (showing f)] (- cx (xs id)))) (range 6)))
"and the lane moves on every frame, odd ones included")))
(defn- drawn
"What every frame draws, as sorted values, so a picture can be compared
without naming the cels that produced it."
[doc fs]
(let [at (sample doc fs)]
(mapv #(sort (vals (get at %))) fs)))
(deftest a-drawing-goes-anywhere-in-the-lane-and-ripples-what-follows
(let [doc (document)
keys-of #(get-in % [:symbols :main :nodes :girl :channels [:xform :pos] :keys])
spans #(mapv (fn [id] (node/placed-span (get-in % [:symbols :main :nodes id])))
[:a :n :b :insert])
r (lane/append-drawing doc :main :girl :n :drawing-n
{:at 4 :extent :grow-symbol})]
(is (= [[0 4] [4 5] [5 9] [9 13]] (spans (:clip r))))
(is (= 13 (get-in r [:clip :symbols :main :frames])))
(is (= (keys-of doc) (keys-of (:clip r))) "lane keys stay where they were authored")
(is (= :n (:selection r)))
(is (= 4 (:frame r)))
(is (empty? (clip/problems (:clip r))))
;; The same command with no room refuses, and says how much it needs.
(is (= 13 (:required-frames (lane/append-drawing doc :main :girl :n :drawing-n {:at 4}))))
;; At the very front everything moves.
(is (= [[1 5] [0 1] [5 9] [9 13]]
(spans (:clip (lane/append-drawing doc :main :girl :n :drawing-n
{:at 0 :extent :grow-symbol})))))
;; Inside a cel is not a position for another one.
(is (re-find #"split it first"
(:refused (lane/append-drawing doc :main :girl :n :drawing-n
{:at 2 :extent :grow-symbol}))))
(is (:refused (lane/append-drawing doc :main :girl :n :drawing-n
{:at -1 :extent :grow-symbol})))
(is (:refused (lane/append-drawing doc :main :girl :n :drawing-n
{:at ##Inf :extent :grow-symbol})))
;; Reuse and duplicate take a position too; it is one placement rule.
(is (= [4 5] (node/placed-span
(get-in (lane/reuse-drawing doc :main :girl :n :drawing-b
{:at 4 :extent :grow-symbol})
[:clip :symbols :main :nodes :n]))))
(is (= [4 5] (node/placed-span
(get-in (lane/duplicate-drawing doc :main :b :n
{:at 4 :extent :grow-symbol})
[:clip :symbols :main :nodes :n]))))))
(deftest split-then-place-puts-a-drawing-inside-a-hold
;; The two commands the doc asks for, composed: neither one guesses.
(let [doc (document)
cut (:clip (span/split doc :main :a 2 :right))
r (lane/append-drawing cut :main :girl :n :drawing-n
{:at 2 :extent :grow-symbol})
after (:clip r)]
(is (= [[0 2] [2 3] [3 5] [5 9] [9 13]]
(mapv #(node/placed-span (get-in after [:symbols :main :nodes %]))
[:a :n :right :b :insert])))
(is (= (get-in doc [:symbols :main :nodes :girl :channels])
(get-in after [:symbols :main :nodes :girl :channels]))
"the performance is still timed the way it was authored")
(is (empty? (clip/problems after)))))
(deftest a-three-frame-correction-crosses-a-drawing-boundary
;; The lane model's worked example. The correction belongs to the GIRL, so it
;; applies across whichever drawings are showing under it, and outside its
;; three frames the animation evaluates exactly as it did before.
(let [doc (document)
fs (range 12)
before (drawn doc fs)
beat (ch/layer :beat [3 6] :offset (ch/framed [30 0]))
c (update-in doc [:symbols :main :nodes :girl :channels [:xform :pos] :over]
(fnil conj []) beat)
after (drawn c fs)
outside [0 1 2 6 7 8 9 10 11]]
(is (empty? (clip/problems c)))
(is (= (mapv before outside) (mapv after outside))
"outside the support, frame for frame identical")
(let [at (sample c [3 4 5])]
;; Frame 3 shows drawing A and frames 4 and 5 show drawing B: one
;; correction, reaching across the cut between them.
(is (= 70 (get-in at [3 [:a :mark]])))
(is (= 90 (get-in at [4 [:b :mark]])))
(is (= 102 (get-in at [5 [:b :mark]])) "and B's own correction still applies under it")
(is (= [-10 0 10] (mapv (fn [f] (js/Math.round (get-in at [f :plate]))) [3 4 5]))
"while the background, which is not in the lane, does not move"))
;; One document change: one step, and it persists in the channel's own leaf.
(let [b (leaf/leaves :p doc)
a (leaf/leaves :p c)
h (-> nil history/hold (history/record b a 0) history/settle)]
(is (= 1 (count (:done h))))
(is (= b (:leaves (history/undo h a))))
(is (= c (leaf/clip :p a)) "a correction needs no codec of its own"))))
(deftest a-correction-on-one-cel-travels-with-it
;; The other half of ownership: a layer on a cel is in that
;; cel's own frames, so moving the cel moves the correction and
;; nothing has to say so.
(let [beat (ch/layer :beat [0 2] :offset (ch/framed [7 0]))
doc (update-in (document) [:symbols :main :nodes :b :channels [:xform :pos] :over]
(fnil conj []) beat)
moved (:clip (lane/extend-hold doc :main :a 2 {:extent :grow-symbol}))]
;; Stated as the difference from the same document without the correction,
;; so the claim is about WHERE the layer applies and not about arithmetic.
(let [nudge (fn [with without f]
(- (get-in (sample with [f]) [f [:b :mark]])
(get-in (sample without [f]) [f [:b :mark]])))]
(is (= [7 7 0 0] (mapv #(nudge doc (document) %) [4 5 6 7]))
"B's first two frames, which are lane frames 4 and 5")
(is (= [7 7 0 0]
(mapv #(nudge moved (:clip (lane/extend-hold (document) :main :a 2
{:extent :grow-symbol}))
%)
[6 7 8 9]))
"and after A's hold grows, B's first two frames, which are now 6 and 7"))
(is (= (get-in doc [:symbols :main :nodes :b :channels])
(get-in moved [:symbols :main :nodes :b :channels]))
"the layer itself was not touched by the retiming")
(is (empty? (clip/problems moved)))))
(defn- spans [clip ids]
(mapv #(node/placed-span (get-in clip [:symbols :main :nodes %])) ids))
(deftest blanking-leaves-a-gap-and-does-not-close-it
(let [doc (document)
r (lane/blank doc :main :girl [5 7] {:id :rest})
after (:clip r)]
;; B spanned the range, so it became two cels with a hole between them.
(is (= [[0 4] [4 5] [7 8] [8 12]] (spans after [:a :b :rest :insert])))
(is (= :rest (:selection r)))
(let [at (sample after [4 5 6 7])]
(is (= #{:plate} (set (keys (at 5)))) "nothing is drawn on a blanked frame")
(is (= #{:plate} (set (keys (at 6)))))
(is (get-in at [4 [:b :mark]]))
(is (get-in at [7 [:rest :mark]])))
(is (= 12 (get-in after [:symbols :main :frames])))
(is (empty? (clip/problems after)))))
(deftest blanking-a-whole-cel-removes-it-and-keeps-its-drawing
(let [doc (document)
after (:clip (lane/blank doc :main :girl [4 8] {}))]
(is (nil? (get-in after [:symbols :main :nodes :b])))
(is (= [[0 4] [8 12]] (spans after [:a :insert])) "and moves nothing")
(is (= (get-in doc [:symbols :drawing-b]) (get-in after [:symbols :drawing-b]))
"a lane does not own its content")
(is (empty? (clip/problems after)))))
(deftest blanking-a-range-trims-what-it-only-partly-covers
(let [doc (document)
after (:clip (lane/blank doc :main :girl [3 9] {}))]
(is (= [[0 3] [9 12]] (spans after [:a :insert])))
(is (nil? (get-in after [:symbols :main :nodes :b])))
(is (= (get-in (sample doc [9]) [9 [:insert :mark]])
(get-in (sample after [9]) [9 [:insert :mark]]))
"the insert kept its own frames, so frame 9 shows what it showed")
(is (empty? (clip/problems after)))))
(deftest overwrite-clears-one-frame-and-does-not-ripple-what-follows
(let [r (lane/overwrite-drawing (document) :main :girl :n :drawing-n 5
{:extent :keep :remainder-id :right})
after (:clip r)
nodes (get-in after [:symbols :main :nodes])]
(is (= :n (:selection r)))
(is (= [[0 4] [4 5] [5 6] [6 8] [8 12]]
(mapv #(node/placed-span (get nodes %)) [:a :b :n :right :insert])))
(is (= :drawing-b (node/source (:right nodes))))
(is (= 12 (get-in after [:symbols :main :frames])))
(is (empty? (clip/problems after)))))
(deftest blank-refuses-what-it-cannot-do-in-one-piece
(let [doc (document)]
(is (re-find #"free ID" (:refused (lane/blank doc :main :girl [5 7] {})))
"splitting a cel needs an ID for the remainder")
(is (:refused (lane/blank doc :main :girl [5 7] {:id :a})) "and a free one")
(is (:refused (lane/blank doc :main :girl [7 5] {})))
(is (:refused (lane/blank doc :main :girl [5 5] {})))
(is (:refused (lane/blank doc :main :girl [5 6.5] {})))
(is (:refused (lane/blank doc :main :plate [0 2] {})))))
(deftest the-shot-length-is-authored-and-emptying-a-lane-does-not-shorten-it
;; The window and the occupied extent are two facts. A shot with nothing in
;; the last half is a shot somebody authored that long, and deleting the last
;; drawing must not quietly shorten the film.
(let [doc (document)
empty-lane (:clip (lane/blank doc :main :girl [0 12] {}))]
(is (empty? (symbol/lane-clips (get-in empty-lane [:symbols :main :nodes]) :girl)))
(is (= 12 (get-in empty-lane [:symbols :main :frames])))
(is (empty? (clip/problems empty-lane)))
;; Growing is still the caller's word, and only ever grows.
(is (:refused (lane/append-drawing empty-lane :main :girl :n :drawing-n {:at 20})))
(is (= 21 (get-in (lane/append-drawing empty-lane :main :girl :n :drawing-n
{:at 20 :extent :grow-symbol})
[:clip :symbols :main :frames])))
(is (= 12 (get-in (:clip (span/trim doc :main :insert :out 9))
[:symbols :main :frames]))
"and trimming the last cel leaves the window where it was")))
(deftest a-take-placed-in-a-lane-is-still-heard
;; `bring/take` puts a take's sound INSIDE the symbol it makes, so that
;; "wherever the symbol is placed it is heard". A lane is one of the places it
;; can be placed, and must not be the one place that goes silent.
(let [doc (assoc-in (document) [:symbols :take]
{:id :take :frames 10 :fps 24
:nodes {:pic {:id :pic :kind :instance :z "a"
:source {:symbol :wave} :span [0 10]
:time {:mode :map :at 0 :rate 1}
:playback {:in 0 :speed 1 :end :stop}}
:sound {:id :sound :name "sound" :kind :audio
:parent nil :z "z-sound"
:source {:footage "f1"} :span [0 10]
:time {:mode :map :at 0 :rate 1}}}})
at-root (clip/place-symbol doc nil :main :take 0 :root nil)
in-lane (:clip (lane/place-symbol doc nil :main :girl :drop :take 0
{:extent :grow-symbol :remainder-id :tail}))]
(is (= 1 (count (nest/audio-tracks at-root :main)))
"a take placed at the root is heard")
(is (some? in-lane) "the take goes into the lane")
(is (= 1 (count (nest/audio-tracks in-lane :main)))
"and is still heard from inside a lane")))
(deftest a-sound-is-a-clip-in-a-lane-like-any-other
;; Everything in the timeline is a lane, audio included: a sound claims lane
;; time by the same rule, and what a lane will not do is hold both kinds.
(let [made (lane/add-lane (document) :main :track)
seeded (clip/place-sound (:clip made) :main {:sound "s1"} "voice" 6 1 2 :vo)
result (lane/adopt seeded :main :track :vo 2 {:extent :grow-symbol})
after (:clip result)
n (get-in after [:symbols :main :nodes :vo])]
(is (nil? (:refused result)) (str (:refused result)))
(is (= :track (:parent n)))
(is (= [2 8] (node/placed-span n)))
(is (empty? (clip/problems after)))
(is (= 1 (count (nest/audio-tracks after :main)))
"a sound in a lane is still heard")
(is (= [:vo] (mapv :id (symbol/lane-clips (get-in after [:symbols :main :nodes]) :track))))
;; The one thing a lane refuses: being half picture and half sound, which
;; is the explicit capability rather than a guess per frame.
(let [mixed (lane/place-symbol after nil :main :track :also :wave 2
{:extent :grow-symbol :remainder-id :rest})]
(is (:refused mixed))
(is (re-find #"picture or sound" (str (:refused mixed))))
(is (= [:vo] (mapv :id (symbol/lane-clips (get-in after [:symbols :main :nodes]) :track)))
"and the sound it would have had to delete to make room is still there"))))

812
frontend/test/arthur/domain/sequence_test.cljs Normal file
View file

@ -0,0 +1,812 @@
(ns arthur.domain.sequence-test
"The commands that need a SEQUENCE, which is now a symbol drawn as a lane and
its own children rather than a group with `:layout :sequence`. Was
`lane_test`; the fixtures changed and the assertions did not, except where
they are called out below as behaviour that changed on purpose."
(:require [cljs.test :refer [deftest is testing]]
[arthur.domain.bring :as bring]
[arthur.domain.channel :as ch]
[arthur.domain.clip :as clip]
[arthur.domain.history :as history]
[arthur.domain.leaf :as leaf]
[arthur.domain.nest :as nest]
[arthur.domain.node :as node]
[arthur.domain.palette :as pal]
[arthur.domain.pick :as pick]
[arthur.domain.span :as span]
[arthur.domain.symbol :as symbol]))
(defn drawing [id x frames]
{:id id :frames frames
:nodes {:mark {:id :mark :kind :rect :z "a"
:channels {[:geom :size] (ch/framed 4)
[:xform :pos] (ch/framed [x 0])}}}})
(defn cel
"A clip of the sequence. PARENTLESS, because the symbol is the container."
[id source at duration speed]
{:id id :kind :instance :z (name id)
:source {:symbol source} :playback {:in 0 :speed speed :end :stop}
:time {:at at :rate 1} :span [0 duration]})
(defn document
"`:main`, drawn as a lane, holding three clips and a background shape.
`:plate` HAS NO SPAN, so it is on screen for the whole shot and is not in the
sequence at all — which is what `symbol/children` skips, and the reason an
ordinary shape sitting in a lane symbol is not something an edge edit can trim."
[]
(let [a (cel :a :drawing-a 0 4 0)
b (assoc-in (cel :b :drawing-b 4 4 0)
[:channels [:xform :pos]] (ch/keyed {0 [0 0] 1 [2 0]} :hold))
insert (assoc-in (cel :insert :wave 8 4 1) [:playback :in] 3)]
{:name "cels" :fps 24 :width 320 :height 200
:symbols
{:main {:id :main :frames 12 :display :lane
:nodes {:a a :b b :insert insert
:plate {:id :plate :kind :rect :z "a"
:channels {[:geom :size] (ch/framed 10)
[:xform :pos] (ch/keyed {0 [-40 0] 11 [70 0]} :linear)}}}}
:drawing-a (drawing :drawing-a 10 1)
:drawing-b (drawing :drawing-b 20 1)
:wave (assoc-in (drawing :wave 0 10) [:nodes :mark :channels [:xform :pos]]
(ch/keyed {0 [0 0] 9 [900 0]} :linear))}}))
(defn shot
"`doc` with `:main` placed in a containing symbol as the instance `:girl`,
carrying the keyed transform the LANE GROUP used to carry, and the plate moved
out to be the background that is not in the sequence.
THE PLACING INSTANCE IS WHERE THE LANE'S TRANSFORM WENT. A lane was a group
and could be animated; a symbol cannot, so what moves a whole sequence is now
the instance that places it. These are the tests that used to animate `:girl`
the group and now animate `:girl` the instance — the same six keys, and the
same answer frame for frame."
[doc]
(-> doc
(update-in [:symbols :main :nodes] dissoc :plate)
(assoc-in [:symbols :shot]
{:id :shot :frames 12 :fps 24
:nodes {:girl {:id :girl :kind :instance :z "b" :span [0 12]
:time {:mode :map :at 0 :rate 1}
:source {:symbol :main}
:playback {:in 0 :speed 1 :end :stop}
:channels {[:xform :pos]
(ch/keyed {0 [0 0] 6 [60 0] 12 [0 0]} :linear)}}
:plate (get-in doc [:symbols :main :nodes :plate])}})))
(defn sample-in [doc sid fs]
(let [r (clip/resolver doc sid nil pal/index-of nil)]
(into {} (map (fn [f] [f (into {} (map (juxt :node :cx)) (r f))])) fs)))
(defn sample [doc fs] (sample-in doc :main fs))
(deftest one-sequence-mixes-held-drawings-and-playing-content
(let [doc (document) at (sample doc (range 12))]
(is (empty? (clip/problems doc)))
(is (= 10 (get-in at [3 [:a :mark]])))
(is (= 20 (get-in at [4 [:b :mark]])))
(is (= 22 (get-in at [5 [:b :mark]])))
(is (= 300 (get-in at [8 [:insert :mark]])))
(is (= 600 (get-in at [11 [:insert :mark]])))
(is (= (zipmap (range 12) (range -40 80 10))
(into {} (map (fn [[f ops]] [f (js/Math.round (:plate ops))])) at)))
(is (nil? (get-in at [4 [:a :mark]])) "half-open cuts have a single owner")))
(deftest the-placing-instance-animates-the-whole-sequence
;; What `:girl` the lane group used to do, `:girl` the instance does: one
;; transform over whichever drawing is showing under it, every frame.
(let [doc (shot (document)) at (sample-in doc :shot (range 12))]
(is (empty? (clip/problems doc)))
(is (= 40 (get-in at [3 [:girl :a :mark]])))
(is (= 60 (get-in at [4 [:girl :b :mark]])))
(is (= 72 (get-in at [5 [:girl :b :mark]])))
(is (= 340 (get-in at [8 [:girl :insert :mark]])))
(is (= 610 (get-in at [11 [:girl :insert :mark]])))
(is (= (zipmap (range 12) (range -40 80 10))
(into {} (map (fn [[f ops]] [f (js/Math.round (:plate ops))])) at))
"and the background, which is not in the sequence, does not move with it")))
(deftest cel-ripple-keeps-the-containers-keys-and-moves-cel-corrections
(let [doc (shot (document))
result (span/extend-hold doc :main :a 2 {:extent :grow-symbol})
after (:clip result)
nodes (get-in after [:symbols :main :nodes])]
(is (= :a (:selection result)))
(is (= 14 (get-in after [:symbols :main :frames])))
(is (= [0 6] (node/placed-span (:a nodes))))
(is (= [6 10] (node/placed-span (:b nodes))))
(is (= [10 14] (node/placed-span (:insert nodes))))
(doseq [id [:a :b :insert]]
(is (= (get-in doc [:symbols :main :nodes id :channels]) (:channels (nodes id))))
(is (= (get-in doc [:symbols :main :nodes id :playback]) (:playback (nodes id)))))
(is (= (get-in doc [:symbols :shot :nodes :girl])
(get-in after [:symbols :shot :nodes :girl]))
"re-spanning a sequence does not touch what places it")
(let [at (sample-in after :shot [5 6 7 10])]
(is (= 60 (get-in at [5 [:girl :a :mark]])))
(is (= 80 (get-in at [6 [:girl :b :mark]])))
(is (= 72 (get-in at [7 [:girl :b :mark]])) "B's correction follows B")
(is (= 320 (get-in at [10 [:girl :insert :mark]])) "insert starts on source frame 3"))
(is (empty? (clip/problems after)))
(is (= (assoc-in doc [:symbols :main :frames] 14)
(:clip (span/extend-hold after :main :a -2 {})))
"shrinking restores content, except the explicitly grown shot")))
(deftest overflow-and-invalid-edits-are-atomic
(let [doc (document)
result (span/extend-hold doc :main :a 2 {})]
(is (:refused result))
(is (= 14 (:required-frames result)))
(is (not (contains? result :clip)))
(doseq [delta [0 -4 0.5 js/NaN]]
(is (:refused (span/extend-hold doc :main :a delta {}))))
(is (:refused (span/extend-hold doc :main :insert 1 {})))
(is (:refused (span/extend-hold doc :main :missing 1 {})))
(is (:refused (span/extend-hold (update-in doc [:symbols :main] dissoc :display)
:main :a 2 {:extent :grow-symbol}))
"lengthening a hold is a sequence edit, so it needs a symbol drawn as one")))
(deftest dragging-a-cel-edge-trims-neighbours-or-ripples-them
(let [doc (document)
clips #(mapv node/placed-span (symbol/children (get-in % [:symbols :main :nodes])))
plain (:clip (span/resize-out doc :main :a 6 {}))
across (:clip (span/resize-out doc :main :a 9 {}))
ripple (:clip (span/resize-out doc :main :a 6 {:ripple? true
:extent :grow-symbol}))
shrink (:clip (span/resize-out doc :main :a 2 {:ripple? true}))]
(is (= [[0 6] [6 8] [8 12]] (clips plain))
"a normal grow eats the beginning of the adjacent cel")
(is (= [[0 9] [9 12]] (clips across))
"a long grow removes wholly consumed cels and trims the survivor")
(is (= [[0 6] [6 10] [10 14]] (clips ripple))
"shift-grow moves every later cel")
(is (= [[0 2] [2 6] [6 10]] (clips shrink))
"shift-shrink pulls every later cel left")
(is (:refused (span/resize-out doc :main :a 0 {})))
(is (:refused (span/resize-out doc :main :a 2.5 {})))))
(deftest outside-lane-mode-an-edge-edit-disturbs-nothing
;; The claim-time rule FOLLOWS THE MODE. The same document not drawn as a lane
;; is a composition, and things in a composition are allowed to be on screen
;; together — so growing one clip over another simply does that.
(let [doc (update-in (document) [:symbols :main] dissoc :display)
after (:clip (span/resize-out doc :main :a 6 {}))
nodes (get-in after [:symbols :main :nodes])]
(is (= [0 6] (node/placed-span (:a nodes))))
(is (= [4 8] (node/placed-span (:b nodes))) "the neighbour is left exactly as it was")
(is (= 1 (count (symbol/overlaps (get-in after [:symbols :main])))))
(is (empty? (clip/problems after)) "and an overlap is not a reason a document will not load")))
(deftest the-middle-of-a-cut-rolls-both-edges
(let [doc (document)
clips #(mapv node/placed-span (symbol/children (get-in % [:symbols :main :nodes])))
rolled (:clip (span/roll doc :main :a :b 6))
right-only (:clip (span/resize-in doc :main :b 6))
grown-left (:clip (span/resize-in doc :main :b 2))]
(is (= [[0 6] [6 8] [8 12]] (clips rolled))
"the shared cut moves without moving either clip")
(is (= [[0 4] [6 8] [8 12]] (clips right-only))
"the right side of the junction trims only the right clip")
(is (= [[0 2] [2 8] [8 12]] (clips grown-left))
"growing the right clip left trims the neighbour instead of overlapping")
(is (:refused (span/roll doc :main :a :b 0)))
(is (:refused (span/roll doc :main :a :insert 6)))
(is (:refused (span/roll (update-in doc [:symbols :main] dissoc :display) :main :a :b 6))
"a roll is a sequence edit")))
(deftest a-gap-is-an-uncovered-interval
(let [doc (update-in (document) [:symbols :main :nodes] dissoc :b)
at (sample doc [3 4 7 8])]
(is (= #{:plate} (set (keys (at 4)))))
(is (= #{:plate} (set (keys (at 7)))))
(is (get-in at [8 [:insert :mark]]))
(is (empty? (clip/problems doc)))))
(deftest an-overlap-is-a-bug-report-and-not-a-reason-not-to-load
;; It used to be `clip/problems`, which means the document will not load. A
;; display hint must never be able to do that, so it is its own diagnostic.
(let [clashing (assoc-in (document) [:symbols :main :nodes :b :time :at] 3)]
(is (= [[:a :b]] (symbol/overlaps (get-in clashing [:symbols :main]))))
(is (empty? (clip/problems clashing))
"and the document still loads, to be drawn visibly wrong")
(is (empty? (symbol/overlaps (get-in (document) [:symbols :main]))))
(is (empty? (clip/problems
(update-in (document) [:symbols :main :nodes] dissoc :a :b :insert)))
"an empty sequence is valid — a shot is authored before it is filled")
(is (seq (clip/problems
(assoc-in (document) [:symbols :main :nodes :a :span] [0 ##Inf]))))
(is (seq (clip/problems
(assoc-in (document) [:symbols :main :nodes :a :playback :speed] -1))))
(is (seq (clip/problems
(assoc-in (document) [:symbols :main :nodes :a :layout] :sequence)))
":layout is not a node field any more")
(is (seq (node/problems {:id :old :kind :instance :z "a"
:channels {[:source] (ch/framed {:of :wave :in 0})}}))
"the obsolete format is rejected")))
(deftest no-command-can-commit-an-overlap
;; THE INVARIANT, ASSERTED OVER THE COMMANDS rather than reasoned about: every
;; one of them commits through `span/finish`, so sampling them is enough.
;; Sampled, in the style of `drawn`, rather than computing expected spans by
;; hand — what is being claimed is that no result holds an overlap, whatever
;; the numbers are.
(let [doc (document)
every-command
(concat
(for [to (range -1 15)] #(span/resize-out % :main :a to {:extent :grow-symbol}))
(for [to (range -1 15)] #(span/resize-out % :main :b to {:ripple? true :extent :grow-symbol}))
(for [to (range -1 15)] #(span/resize-in % :main :b to))
(for [to (range -1 15)] #(span/roll % :main :a :b to))
(for [cut (range -1 15)] #(span/split % :main :insert cut :piece))
(for [to (range -1 15)] #(span/trim % :main :insert :out to))
(for [to (range -1 15)] #(span/move % :main :insert to))
(for [d (range -5 6)] #(span/extend-hold % :main :a d {:extent :grow-symbol}))
(for [a (range 0 13) b (range 0 13)] #(span/blank % :main [a b] {:id :rest}))
(for [at (range -1 15)] #(span/append-drawing % :main :n :drawing-n
{:at at :extent :grow-symbol}))
(for [at (range -1 15)] #(span/reuse-drawing % :main :n :drawing-b
{:at at :extent :grow-symbol}))
(for [at (range -1 15)] #(span/duplicate-drawing % :main :b :n
{:at at :extent :grow-symbol}))
(for [at (range -1 15)] #(span/overwrite-drawing % :main :n :drawing-n at
{:extent :grow-symbol
:remainder-id :rest}))
(for [at (range -1 15)] #(span/place-symbol % nil :main :n :wave at
{:extent :grow-symbol
:remainder-id :rest}))
(for [at (range -1 15)] #(span/adopt % :main :b at {:extent :grow-symbol
:remainder-id :rest}))
[#(span/make-unique (:clip (span/reuse-drawing % :main :n :drawing-a
{:extent :grow-symbol}))
:main :n {})])
results (keep (fn [command] (:clip (command doc))) every-command)]
(is (< 190 (count results)) "the sample is of commands that actually did something")
(doseq [after results]
(is (empty? (symbol/overlaps (get-in after [:symbols :main])))
(str "a command committed an overlap: "
(pr-str (mapv (juxt :id node/placed-span)
(symbol/children (get-in after [:symbols :main :nodes]))))))
(is (empty? (clip/problems after))))))
(deftest turning-lane-mode-on-is-the-one-thing-that-can-be-refused
(let [composed (-> (document)
(update-in [:symbols :main] dissoc :display)
(assoc-in [:symbols :main :nodes :b :time :at] 3))
refused (span/draw-as-lane composed :main true {})
trimmed (:clip (span/draw-as-lane composed :main true {:trim? true}))]
(is (:refused refused))
(is (= 1 (:required-trim refused)))
(is (nil? (:clip refused)) "and nothing moved")
(is (= :lane (get-in trimmed [:symbols :main :display])))
(is (= [[0 3] [3 7] [8 12]]
(mapv node/placed-span (symbol/children (get-in trimmed [:symbols :main :nodes]))))
"the retry trims later-claims-from-earlier, the rule everything else follows")
(is (empty? (symbol/overlaps (get-in trimmed [:symbols :main]))))
(is (empty? (clip/problems trimmed)))
;; A clip the next one wholly covers has nothing left to be.
(let [buried (assoc-in composed [:symbols :main :nodes :b :time :at] 0)
after (:clip (span/draw-as-lane buried :main true {:trim? true}))]
(is (nil? (get-in after [:symbols :main :nodes :a])))
(is (empty? (symbol/overlaps (get-in after [:symbols :main])))))
;; Off is always possible, and changes nothing but the hint.
(let [off (:clip (span/draw-as-lane (document) :main false {}))]
(is (nil? (get-in off [:symbols :main :display])))
(is (= (get-in (document) [:symbols :main :nodes])
(get-in off [:symbols :main :nodes]))))
(is (:refused (span/draw-as-lane (document) :nothing-here true {})))
(is (= :lane (get-in (:clip (span/draw-as-lane (document) :main true {}))
[:symbols :main :display]))
"a sequence that is already one turns on with nothing to trim")))
(deftest playback-is-independent-of-property-channel-shape
(let [doc (document)
n (get-in doc [:symbols :main :nodes :a])
keyed (node/toggle-key n [:xform :rot] 0 nil)
unkeyed (node/toggle-key keyed [:xform :rot] 0 nil)]
(doseq [n [n keyed unkeyed]]
(is (= {:symbol :drawing-a :frame 0} (node/placed-frame n 11 1))))
(let [n (get-in doc [:symbols :main :nodes :insert])]
(is (= {:symbol :wave :frame 5} (node/placed-frame n 2 10)))
(is (nil? (node/placed-frame n 7 10)))
(is (= 9 (:frame (node/placed-frame (assoc-in n [:playback :end] :hold) 9 10))))
(is (= 2 (:frame (node/placed-frame (assoc-in n [:playback :end] :loop) 9 10)))))))
(deftest navigation-and-hit-testing-use-the-same-source-time
(let [doc (document)
n (get-in doc [:symbols :main :nodes :insert])]
(is (= 5 (:frame (nest/inside doc nil :main [:insert] 10))))
(is (= {:at 5 :rate 1} (:time (nest/inside doc nil :main [:insert] 10))))
(is (= 0 (:frame (nest/inside doc nil :main [:a] 3))))
(is (nil? (:time (nest/inside doc nil :main [:a] 3))))
(is (nil? (nest/inside doc nil :main [:a] 4)))
(is (= ((pick/bounds-of doc nil :main n) 2)
((pick/bounds-of doc nil :main (assoc-in n [:playback :in] 5)) 0)))))
(deftest seeking-and-source-reuse-do-not-share-cursors
(let [doc (assoc-in (document) [:symbols :main :nodes :b :source :symbol] :drawing-a)
fs [11 0 5 3 8 4 10 1 6 2 9 7]
at (sample doc fs)]
(is (= at (sample doc (reverse fs))))
(is (= at (sample doc (range 12))))
(let [edited (assoc-in doc [:symbols :drawing-a :nodes :mark :channels [:xform :pos]]
(ch/framed [99 0]))]
(is (= 99 (get-in (sample edited [0 4]) [0 [:a :mark]])))
(is (= 99 (get-in (sample edited [0 4]) [4 [:b :mark]]))))))
(deftest cel-identities-and-playback-round-trip
(let [doc (:clip (span/extend-hold (document) :main :a 2 {:extent :grow-symbol}))
leaves (leaf/leaves :project doc)]
(is (= doc (leaf/clip :project leaves)))
(is (contains? leaves "clip/project/symbol/main/node/a"))
(is (= :lane (get-in (leaf/clip :project leaves) [:symbols :main :display]))
"lane mode is saved like any other field of a symbol")
(let [{copied :clip ids :ids}
(bring/symbols (assoc-in (clip/blank) [:symbols :drawing-a] (drawing :drawing-a 99 1))
doc [:main] {})]
(is (= :drawing-a-2 (:drawing-a ids)))
(is (= #{:drawing-a-2 :drawing-b :wave} (clip/places copied (:main ids))))
(is (empty? (clip/problems copied))))))
(deftest one-transaction-undoes-the-ripple-and-shot-extension
(let [doc (document)
after (:clip (span/extend-hold doc :main :a 2 {:extent :grow-symbol}))
before-leaves (leaf/leaves :p doc)
after-leaves (leaf/leaves :p after)
h (-> nil history/hold (history/record before-leaves after-leaves 0) history/settle)
undo (history/undo h after-leaves)
redo (history/redo (:history undo) (:leaves undo))]
(is (= 1 (count (:done h))))
(is (= before-leaves (:leaves undo)))
(is (= after-leaves (:leaves redo)))))
(deftest a-new-document-is-ordinary-and-a-lane-is-created-explicitly
(let [doc (clip/blank)
lane (:clip (span/draw-as-lane doc :main true {}))
a (:clip (span/append-drawing lane :main :a :drawing-a {}))
b (:clip (span/append-drawing a :main :b :drawing-b {}))]
(is (= {} (get-in doc [:symbols :main :nodes])))
(is (nil? (get-in doc [:symbols :main :display])))
(is (= :lane (get-in lane [:symbols :main :display])))
(is (empty? (clip/problems b)))
(is (= [1 2] (node/placed-span (get-in b [:symbols :main :nodes :b]))))
(is (= 0 (get-in b [:symbols :main :nodes :b :playback :speed])))
(is (:refused (span/append-drawing b :main :a :new {})))))
(deftest arbitrary-symbols-drop-into-the-sequence-and-claim-their-time
(let [doc (document)
dropped (span/place-symbol doc nil :main :clip :wave 2
{:extent :grow-symbol :remainder-id :tail})
after (:clip dropped)
clips (symbol/children (get-in after [:symbols :main :nodes]))]
(is (= :clip (:selection dropped)))
(is (= [[0 2] [2 12]] (mapv node/placed-span clips))
"the natural ten-frame symbol claims [2,12), trimming/removing incumbents")
(is (= :wave (node/source (second clips))))
(is (= 1 (:speed (node/playback-of (second clips))))
"a dropped symbol plays; it is not converted into a drawing hold")
(is (empty? (clip/problems after)))
;; Outside lane mode the same drop claims nothing.
(let [composed (update-in doc [:symbols :main] dissoc :display)
after (:clip (span/place-symbol composed nil :main :clip :wave 2
{:extent :grow-symbol :remainder-id :tail}))]
(is (= [[0 4] [2 12] [4 8] [8 12]]
(mapv node/placed-span (symbol/children (get-in after [:symbols :main :nodes]))))
"it is simply placed, on screen with what was already there"))))
(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"
:source {:symbol :wave} :span [0 3]
:time {:at 1 :rate 1}
:playback {:in 2 :speed 1 :end :stop}})
result (span/adopt doc :main :badge 5
{:extent :grow-symbol :remainder-id :tail})
after (:clip result)
n (get-in after [:symbols :main :nodes :badge])]
(is (= [5 8] (node/placed-span n)))
(is (= {:in 2 :speed 1 :end :stop} (:playback n))
"a move changes placement, not source timing")
(is (= [[0 4] [4 5] [5 8] [8 12]]
(mapv node/placed-span (symbol/children (get-in after [:symbols :main :nodes])))))
(is (empty? (clip/problems after)))
(is (:refused (span/adopt doc :main :plate 5 {})) "and a shape has no frames to place")))
(deftest fractional-placement-rates-convert-the-hold-delta
(let [doc (-> (document)
(assoc-in [:symbols :main :nodes :a :time :rate] 2)
(assoc-in [:symbols :main :nodes :a :span] [0 8]))
after (:clip (span/extend-hold doc :main :a 2 {:extent :grow-symbol}))]
(is (= [0 12] (get-in after [:symbols :main :nodes :a :span])))
(is (= [6 10] (node/placed-span (get-in after [:symbols :main :nodes :b]))))))
(deftest bare-shapes-agree-in-reference-and-playback
(let [sym (drawing :bare 12 1)]
(is (= (symbol/eval-frame sym 0 nil pal/index-of nil)
((symbol/resolver sym nil pal/index-of nil) 0))
"omitted style colour must not crash a missing cursor")))
(deftest audio-follows-only-the-playing-cel
(let [voice {:id :voice :kind :audio :z "a" :source {:sound "voice"}
:span [0 10]
:channels {[:audio :gain] (ch/keyed {0 0 5 1} :linear)}}
doc (-> (document)
(assoc-in [:symbols :wave :nodes :voice] voice)
(assoc-in [:symbols :drawing-a :nodes :voice] voice))
[track :as tracks] (nest/audio-tracks doc :main)]
(is (= 1 (count tracks)) "the frozen drawing contributes no audio")
(is (= [8 12] (node/placed-span track)))
(is (= [3 7] (:span track)) "the source in-point trims the audio too")
(is (= {5 0 10 1} (get-in track [:channels [:audio :gain] :keys])))
(let [moved (:clip (span/extend-hold doc :main :a 2 {:extent :grow-symbol}))
[track] (nest/audio-tracks moved :main)]
(is (= [10 14] (node/placed-span track)))
(is (= [3 7] (:span track))))
;; The retime that used to be the lane group's is the placing instance's.
(let [fast (-> (shot doc)
(assoc-in [:symbols :shot :nodes :girl :time] {:mode :map :at 2 :rate 2})
(assoc-in [:symbols :main :nodes :insert :playback :speed] 2))
[track] (nest/audio-tracks fast :shot)]
(is (= [6 7.75] (node/placed-span track)))
(is (= [3 10] (:span track)))
(is (= 4 (get-in track [:time :rate]))))))
(deftest a-looped-insert-schedules-distinct-audio-intervals
(let [doc (-> (document)
(assoc-in [:symbols :wave :frames] 4)
(assoc-in [:symbols :wave :nodes :voice]
{:id :voice :kind :audio :z "a" :source {:sound "v"} :span [1 3]})
(assoc-in [:symbols :main :nodes :insert :playback]
{:in 3 :speed 1 :end :loop}))]
(is (= [[10 12]] (mapv node/placed-span (nest/audio-tracks doc :main))))))
(deftest the-shot-a-sequence-needs-is-in-its-own-frames
;; CHANGED ON PURPOSE. It used to be that an enclosing retime changed how many
;; frames an edit needed, because the lane was INSIDE the symbol being measured
;; and its clock sat between them. The symbol is now the container, so its
;; `:frames` is its own authored window and how fast some instance plays it is
;; not a fact about it.
(let [doc (shot (document))
slow (assoc-in doc [:symbols :shot :nodes :girl :time] {:mode :map :at 8 :rate 2})]
(is (= 14 (:required-frames (span/extend-hold slow :main :a 2 {}))))
(is (= 14 (:required-frames (span/extend-hold doc :main :a 2 {}))))
(is (= 14 (get-in (span/extend-hold slow :main :a 2 {:extent :grow-symbol})
[:clip :symbols :main :frames])))))
(deftest reuse-shares-content-and-make-unique-decouples-one-cel
(let [doc (document)
shared (:clip (span/reuse-drawing doc :main :c :drawing-a {:extent :grow-symbol}))
edit (fn [c sym x]
(assoc-in c [:symbols sym :nodes :mark :channels [:xform :pos]]
(ch/framed [x 0])))]
(is (:refused (span/reuse-drawing doc :main :c :drawing-a {}))
"the shot has to be extended on purpose")
(is (= :drawing-a (node/source (get-in shared [:symbols :main :nodes :c]))))
(is (= [12 13] (node/placed-span (get-in shared [:symbols :main :nodes :c]))))
(is (empty? (clip/problems shared)))
;; One drawing, two cels: the edit arrives at both.
(let [at (sample (edit shared :drawing-a 99) [0 12])]
(is (= 99 (get-in at [0 [:a :mark]])))
(is (= 99 (get-in at [12 [:c :mark]]))))
(let [unique (:clip (span/make-unique shared :main :c {}))]
(is (= :drawing-a-2 (node/source (get-in unique [:symbols :main :nodes :c]))))
(is (= (:nodes (get-in shared [:symbols :drawing-a]))
(:nodes (get-in unique [:symbols :drawing-a-2])))
"a copy of the same drawing, not an empty one")
(is (= :drawing-a (node/source (get-in unique [:symbols :main :nodes :a])))
"the other cel keeps the original")
(let [at (sample (edit unique :drawing-a 99) [0 12])]
(is (= 99 (get-in at [0 [:a :mark]])))
(is (= 10 (get-in at [12 [:c :mark]])) "the cel made unique is untouched"))
(let [at (sample (edit unique :drawing-a-2 99) [0 12])]
(is (= 10 (get-in at [0 [:a :mark]])) "and does not reach back"))
(is (empty? (clip/problems unique))))
;; Nothing else places drawing-b, so there is nothing to decouple from.
(is (:refused (span/make-unique doc :main :b {})))
(is (:refused (span/make-unique doc :main :plate {}))
"a shape places nothing itself")))
(deftest duplicate-copies-the-drawing-and-not-the-cel
(let [doc (document)
made (:clip (span/duplicate-drawing doc :main :b :d {:extent :grow-symbol}))
n (get-in made [:symbols :main :nodes :d])]
(is (= :drawing-b-2 (node/source n)))
(is (= (:nodes (get-in doc [:symbols :drawing-b]))
(:nodes (get-in made [:symbols :drawing-b-2]))))
(is (= [12 13] (node/placed-span n)))
(is (= {:in 0 :speed 0 :end :stop} (:playback n)))
(is (nil? (:channels n)) "B's own position correction belongs to B's cel")
(is (= (get-in doc [:symbols :main :nodes :b])
(get-in made [:symbols :main :nodes :b]))
"the drawing duplicated is left as it was")
(is (empty? (clip/problems made)))))
(deftest a-shallow-copy-keeps-its-parts-and-a-deep-copy-owns-them
;; A drawing assembled from another symbol: copying it shallowly must keep
;; using that part, and only an explicit deep copy may promise independence.
(let [doc (assoc-in (document) [:symbols :drawing-a :nodes :part]
{:id :part :kind :instance :z "b" :span [0 1]
:time {:at 0 :rate 1} :source {:symbol :wave}
:playback {:in 0 :speed 0 :end :stop}})
copy (fn [opts] (:clip (span/duplicate-drawing
doc :main :a :d (merge {:extent :grow-symbol} opts))))
shallow (copy {})
deep (copy {:deep? true})]
(is (= :wave (node/source (get-in shallow [:symbols :drawing-a-2 :nodes :part]))))
(is (nil? (get-in shallow [:symbols :wave-2])))
(is (= :wave-2 (node/source (get-in deep [:symbols :drawing-a-2 :nodes :part]))))
(is (= (:nodes (get-in doc [:symbols :wave])) (:nodes (get-in deep [:symbols :wave-2]))))
(is (empty? (clip/problems shallow)))
(is (empty? (clip/problems deep)))))
(deftest reuse-refuses-what-would-not-be-a-document
(let [doc (document)]
(is (:refused (span/reuse-drawing doc :main :c :nothing-here {})))
(is (:refused (span/reuse-drawing doc :main :c :main {:extent :grow-symbol}))
"a symbol cannot go inside itself")
(is (:refused (span/reuse-drawing doc :main :a :drawing-a {:extent :grow-symbol}))
"a cel ID in use is not free")
(is (:refused (span/duplicate-drawing doc :main :plate :d {})))))
(deftest drawing-on-twos-does-not-quantize-the-containers-transform
;; Cel length IS the drawing cadence, and it is the only thing on twos here:
;; the instance placing the sequence has its own clock and keeps moving every
;; frame. Stepping it would be the cel cadence leaking into continuous motion.
(let [cel (fn [id source at] (cel id source at 2 0))
doc (-> (shot (document))
(update-in [:symbols :main :nodes] dissoc :a :b :insert)
(update-in [:symbols :main :nodes] merge
{:c0 (cel :c0 :drawing-a 0)
:c1 (cel :c1 :drawing-b 2)
:c2 (cel :c2 :drawing-a 4)}))
xs {:c0 10 :c1 20 :c2 10}
at (sample-in doc :shot (range 6))
showing (fn [f] (first (dissoc (at f) :plate)))]
(is (empty? (clip/problems doc)))
(is (= [:c0 :c0 :c1 :c1 :c2 :c2] (mapv #(second (key (showing %))) (range 6)))
"the drawing showing changes every second frame")
(is (= [0 10 20 30 40 50]
(mapv (fn [f] (let [[[_ id _] cx] (showing f)] (- cx (xs id)))) (range 6)))
"and the sequence moves on every frame, odd ones included")))
(defn- drawn
"What every frame draws, as sorted values, so a picture can be compared
without naming the cels that produced it."
[doc sid fs]
(let [at (sample-in doc sid fs)]
(mapv #(sort (vals (get at %))) fs)))
(deftest a-drawing-goes-anywhere-in-the-sequence-and-ripples-what-follows
(let [doc (shot (document))
keys-of #(get-in % [:symbols :shot :nodes :girl :channels [:xform :pos] :keys])
spans #(mapv (fn [id] (node/placed-span (get-in % [:symbols :main :nodes id])))
[:a :n :b :insert])
r (span/append-drawing doc :main :n :drawing-n {:at 4 :extent :grow-symbol})]
(is (= [[0 4] [4 5] [5 9] [9 13]] (spans (:clip r))))
(is (= 13 (get-in r [:clip :symbols :main :frames])))
(is (= (keys-of doc) (keys-of (:clip r)))
"the container's keys stay where they were authored")
(is (= :n (:selection r)))
(is (= 4 (:frame r)))
(is (empty? (clip/problems (:clip r))))
;; The same command with no room refuses, and says how much it needs.
(is (= 13 (:required-frames (span/append-drawing doc :main :n :drawing-n {:at 4}))))
;; At the very front everything moves.
(is (= [[1 5] [0 1] [5 9] [9 13]]
(spans (:clip (span/append-drawing doc :main :n :drawing-n
{:at 0 :extent :grow-symbol})))))
;; Inside a cel is not a position for another one.
(is (re-find #"split it first"
(:refused (span/append-drawing doc :main :n :drawing-n
{:at 2 :extent :grow-symbol}))))
(is (:refused (span/append-drawing doc :main :n :drawing-n
{:at -1 :extent :grow-symbol})))
(is (:refused (span/append-drawing doc :main :n :drawing-n
{:at ##Inf :extent :grow-symbol})))
;; Reuse and duplicate take a position too; it is one placement rule.
(is (= [4 5] (node/placed-span
(get-in (span/reuse-drawing doc :main :n :drawing-b
{:at 4 :extent :grow-symbol})
[:clip :symbols :main :nodes :n]))))
(is (= [4 5] (node/placed-span
(get-in (span/duplicate-drawing doc :main :b :n
{:at 4 :extent :grow-symbol})
[:clip :symbols :main :nodes :n]))))))
(deftest split-then-place-puts-a-drawing-inside-a-hold
;; The two commands the doc asks for, composed: neither one guesses.
(let [doc (shot (document))
cut (:clip (span/split doc :main :a 2 :right))
r (span/append-drawing cut :main :n :drawing-n {:at 2 :extent :grow-symbol})
after (:clip r)]
(is (= [[0 2] [2 3] [3 5] [5 9] [9 13]]
(mapv #(node/placed-span (get-in after [:symbols :main :nodes %]))
[:a :n :right :b :insert])))
(is (= (get-in doc [:symbols :shot :nodes :girl :channels])
(get-in after [:symbols :shot :nodes :girl :channels]))
"the performance is still timed the way it was authored")
(is (empty? (clip/problems after)))))
(deftest a-three-frame-correction-crosses-a-drawing-boundary
;; The lane model's worked example, with the correction on the INSTANCE that
;; places the sequence: it applies across whichever drawings are showing under
;; it, and outside its three frames the animation evaluates exactly as before.
(let [doc (shot (document))
fs (range 12)
before (drawn doc :shot fs)
beat (ch/layer :beat [3 6] :offset (ch/framed [30 0]))
c (update-in doc [:symbols :shot :nodes :girl :channels [:xform :pos] :over]
(fnil conj []) beat)
after (drawn c :shot fs)
outside [0 1 2 6 7 8 9 10 11]]
(is (empty? (clip/problems c)))
(is (= (mapv before outside) (mapv after outside))
"outside the support, frame for frame identical")
(let [at (sample-in c :shot [3 4 5])]
;; Frame 3 shows drawing A and frames 4 and 5 show drawing B: one
;; correction, reaching across the cut between them.
(is (= 70 (get-in at [3 [:girl :a :mark]])))
(is (= 90 (get-in at [4 [:girl :b :mark]])))
(is (= 102 (get-in at [5 [:girl :b :mark]]))
"and B's own correction still applies under it")
(is (= [-10 0 10] (mapv (fn [f] (js/Math.round (get-in at [f :plate]))) [3 4 5]))
"while the background, which is not in the sequence, does not move"))
;; One document change: one step, and it persists in the channel's own leaf.
(let [b (leaf/leaves :p doc)
a (leaf/leaves :p c)
h (-> nil history/hold (history/record b a 0) history/settle)]
(is (= 1 (count (:done h))))
(is (= b (:leaves (history/undo h a))))
(is (= c (leaf/clip :p a)) "a correction needs no codec of its own"))))
(deftest a-correction-on-one-cel-travels-with-it
;; The other half of ownership: a layer on a cel is in that cel's own frames,
;; so moving the cel moves the correction and nothing has to say so.
(let [beat (ch/layer :beat [0 2] :offset (ch/framed [7 0]))
doc (update-in (document) [:symbols :main :nodes :b :channels [:xform :pos] :over]
(fnil conj []) beat)
moved (:clip (span/extend-hold doc :main :a 2 {:extent :grow-symbol}))]
;; Stated as the difference from the same document without the correction,
;; so the claim is about WHERE the layer applies and not about arithmetic.
(let [nudge (fn [with without f]
(- (get-in (sample with [f]) [f [:b :mark]])
(get-in (sample without [f]) [f [:b :mark]])))]
(is (= [7 7 0 0] (mapv #(nudge doc (document) %) [4 5 6 7]))
"B's first two frames, 4 and 5")
(is (= [7 7 0 0]
(mapv #(nudge moved (:clip (span/extend-hold (document) :main :a 2
{:extent :grow-symbol}))
%)
[6 7 8 9]))
"and after A's hold grows, B's first two frames, which are now 6 and 7"))
(is (= (get-in doc [:symbols :main :nodes :b :channels])
(get-in moved [:symbols :main :nodes :b :channels]))
"the layer itself was not touched by the retiming")
(is (empty? (clip/problems moved)))))
(defn- spans [clip ids]
(mapv #(node/placed-span (get-in clip [:symbols :main :nodes %])) ids))
(deftest blanking-leaves-a-gap-and-does-not-close-it
(let [doc (document)
r (span/blank doc :main [5 7] {:id :rest})
after (:clip r)]
;; B spanned the range, so it became two cels with a hole between them.
(is (= [[0 4] [4 5] [7 8] [8 12]] (spans after [:a :b :rest :insert])))
(is (= :rest (:selection r)))
(let [at (sample after [4 5 6 7])]
(is (= #{:plate} (set (keys (at 5)))) "nothing is drawn on a blanked frame")
(is (= #{:plate} (set (keys (at 6)))))
(is (get-in at [4 [:b :mark]]))
(is (get-in at [7 [:rest :mark]])))
(is (= 12 (get-in after [:symbols :main :frames])))
(is (empty? (clip/problems after)))))
(deftest blanking-a-whole-cel-removes-it-and-keeps-its-drawing
(let [doc (document)
r (span/blank doc :main [4 8] {})
after (:clip r)]
(is (nil? (get-in after [:symbols :main :nodes :b])))
(is (= [[0 4] [8 12]] (spans after [:a :insert])) "and moves nothing")
(is (nil? (:selection r))
"and names nothing, because emptying frames selects nothing sensible")
(is (= (get-in doc [:symbols :drawing-b]) (get-in after [:symbols :drawing-b]))
"a symbol does not own its content")
(is (empty? (clip/problems after)))))
(deftest blanking-a-range-trims-what-it-only-partly-covers
(let [doc (document)
after (:clip (span/blank doc :main [3 9] {}))]
(is (= [[0 3] [9 12]] (spans after [:a :insert])))
(is (nil? (get-in after [:symbols :main :nodes :b])))
(is (= (get-in (sample doc [9]) [9 [:insert :mark]])
(get-in (sample after [9]) [9 [:insert :mark]]))
"the insert kept its own frames, so frame 9 shows what it showed")
(is (empty? (clip/problems after)))))
(deftest overwrite-clears-one-frame-and-does-not-ripple-what-follows
(let [r (span/overwrite-drawing (document) :main :n :drawing-n 5
{:extent :keep :remainder-id :right})
after (:clip r)
nodes (get-in after [:symbols :main :nodes])]
(is (= :n (:selection r)))
(is (= [[0 4] [4 5] [5 6] [6 8] [8 12]]
(mapv #(node/placed-span (get nodes %)) [:a :b :n :right :insert])))
(is (= :drawing-b (node/source (:right nodes))))
(is (= 12 (get-in after [:symbols :main :frames])))
(is (empty? (clip/problems after)))))
(deftest blank-refuses-what-it-cannot-do-in-one-piece
(let [doc (document)]
(is (re-find #"free ID" (:refused (span/blank doc :main [5 7] {})))
"splitting a cel needs an ID for the remainder")
(is (:refused (span/blank doc :main [5 7] {:id :a})) "and a free one")
(is (:refused (span/blank doc :main [7 5] {})))
(is (:refused (span/blank doc :main [5 5] {})))
(is (:refused (span/blank doc :main [5 6.5] {})))
(is (:refused (span/blank (update-in doc [:symbols :main] dissoc :display)
:main [0 2] {}))
"and a composition has no sequence to leave a hole in")))
(deftest the-shot-length-is-authored-and-emptying-it-does-not-shorten-it
;; The window and the occupied extent are two facts. A shot with nothing in
;; the last half is a shot somebody authored that long, and deleting the last
;; drawing must not quietly shorten the film.
(let [doc (document)
emptied (:clip (span/blank doc :main [0 12] {}))]
(is (empty? (symbol/children (get-in emptied [:symbols :main :nodes]))))
(is (= 12 (get-in emptied [:symbols :main :frames])))
(is (empty? (clip/problems emptied)))
;; Growing is still the caller's word, and only ever grows.
(is (:refused (span/append-drawing emptied :main :n :drawing-n {:at 20})))
(is (= 21 (get-in (span/append-drawing emptied :main :n :drawing-n
{:at 20 :extent :grow-symbol})
[:clip :symbols :main :frames])))
(is (= 12 (get-in (:clip (span/trim doc :main :insert :out 9))
[:symbols :main :frames]))
"and trimming the last cel leaves the window where it was")))
(deftest a-take-placed-in-a-sequence-is-still-heard
;; `bring/take` puts a take's sound INSIDE the symbol it makes, so that
;; "wherever the symbol is placed it is heard". A sequence is one of the places
;; it can be placed, and must not be the one place that goes silent.
(let [doc (assoc-in (document) [:symbols :take]
{:id :take :frames 10 :fps 24
:nodes {:pic {:id :pic :kind :instance :z "a"
:source {:symbol :wave} :span [0 10]
:time {:mode :map :at 0 :rate 1}
:playback {:in 0 :speed 1 :end :stop}}
:sound {:id :sound :name "sound" :kind :audio
:parent nil :z "z-sound"
:source {:footage "f1"} :span [0 10]
:time {:mode :map :at 0 :rate 1}}}})
at-root (clip/place-symbol doc nil :main :take 0 :root nil)
placed (:clip (span/place-symbol doc nil :main :drop :take 0
{:extent :grow-symbol :remainder-id :tail}))]
(is (= 1 (count (nest/audio-tracks at-root :main)))
"a take placed at the root is heard")
(is (some? placed) "the take goes into the sequence")
(is (= 1 (count (nest/audio-tracks placed :main)))
"and is still heard from inside one")))
(deftest a-sound-is-a-clip-of-a-sequence-like-any-other
;; A sound claims time by the same rule as a picture, and THERE IS NO MIXTURE
;; RULE ANY MORE: a symbol whose clips are sounds is an audio lane, and that is
;; the whole of it. The refusal that used to say "picture or sound, not both"
;; was a property of a lane node, and there is no lane node.
(let [seeded (clip/place-sound (document) :main {:sound "s1"} "voice" 6 1 2 :vo)
result (span/adopt seeded :main :vo 2 {:extent :grow-symbol})
after (:clip result)
n (get-in after [:symbols :main :nodes :vo])]
(is (nil? (:refused result)) (str (:refused result)))
(is (= [2 8] (node/placed-span n)))
(is (empty? (clip/problems after)))
(is (= 1 (count (nest/audio-tracks after :main)))
"a sound in a sequence is still heard")
(is (contains? (set (map :id (symbol/children (get-in after [:symbols :main :nodes]))))
:vo))
;; Picture over sound is picture claiming the frames, like anything else.
(let [mixed (:clip (span/place-symbol after nil :main :also :wave 2
{:extent :grow-symbol :remainder-id :rest}))]
(is (empty? (symbol/overlaps (get-in mixed [:symbols :main]))))
(is (empty? (clip/problems mixed))))))

266
frontend/test/arthur/domain/span_test.cljs
View file

@ -1,53 +1,22 @@
(ns arthur.domain.span-test
"Split, trim and move, over the two things they have to work on alike: a cel
inside a lane, and a symbol placed straight into a shot. The fixture carries
both on purpose — the commands were lane-gated for as long as a lane was the
only thing anybody had timed, and the point of these tests is that nothing in
them reads a lane."
"Generic span edits in an explicit lane and an ordinary compositing symbol."
(:require [cljs.test :refer [deftest is testing]]
[arthur.domain.channel :as ch]
[arthur.domain.clip :as clip]
[arthur.domain.lane :as lane]
[arthur.domain.node :as node]
[arthur.domain.palette :as pal]
[arthur.domain.sequence-test :as fixture]
[arthur.domain.span :as span]))
(defn- drawing [id x frames]
{:id id :frames frames
:nodes {:mark {:id :mark :kind :rect :z "a"
:channels {[:geom :size] (ch/framed 4)
[:xform :pos] (ch/framed [x 0])}}}})
(defn document [] (fixture/document))
(defn- cel [id source at duration speed]
{:id id :kind :instance :parent :girl :z (name id)
:source {:symbol source} :playback {:in 0 :speed speed :end :stop}
:time {:at at :rate 1} :span [0 duration]})
(defn document
"A lane of three cels, and — the part lane_test's fixture has no equivalent of
— `:badge`, an instance of an animated symbol placed straight into `:main`
with a span of its own and no parent at all. Its frames are the SYMBOL's, so
it is the case where the coordinate a command takes is not lane time."
[]
(let [a (cel :a :drawing-a 0 4 0)
b (cel :b :drawing-b 4 4 0)
insert (assoc-in (cel :insert :wave 8 4 1) [:playback :in] 3)]
{:name "spans" :fps 24 :width 320 :height 200
:symbols
{:main {:id :main :frames 12
:nodes {:girl {:id :girl :kind :group :layout :sequence :z "b"}
:a a :b b :insert insert
:badge {:id :badge :kind :instance :z "c"
:source {:symbol :wave}
:playback {:in 0 :speed 1 :end :stop}
:time {:at 2 :rate 1} :span [0 8]}
:plate {:id :plate :kind :rect :z "a"
:channels {[:geom :size] (ch/framed 10)
[:xform :pos] (ch/keyed {0 [-40 0] 11 [70 0]} :linear)}}}}
:drawing-a (drawing :drawing-a 10 1)
:drawing-b (drawing :drawing-b 20 1)
:wave (assoc-in (drawing :wave 0 10) [:nodes :mark :channels [:xform :pos]]
(ch/keyed {0 [0 0] 9 [900 0]} :linear))}}))
(defn- ordinary-document []
(-> (document)
(update-in [:symbols :main] dissoc :display)
(assoc-in [:symbols :main :nodes :badge]
{:id :badge :kind :instance :z "z"
:source {:symbol :wave}
:playback {:in 0 :speed 1 :end :stop}
:time {:at 2 :rate 1} :span [0 8]})))
(defn- sample [doc fs]
(let [r (clip/resolver doc :main nil pal/index-of nil)]
@ -57,172 +26,67 @@
(let [at (sample doc fs)]
(mapv #(sort (vals (get at %))) fs)))
(defn- spans [clip ids]
(mapv #(node/placed-span (get-in clip [:symbols :main :nodes %])) ids))
(deftest fixtures-state-the-mode-explicitly
(is (= :lane (get-in (document) [:symbols :main :display])))
(is (nil? (get-in (ordinary-document) [:symbols :main :display])))
(is (empty? (clip/problems (document))))
(is (empty? (clip/problems (ordinary-document)))))
(deftest the-fixture-places-one-thing-outside-the-lane
(deftest splitting-preserves-the-picture-in-both-modes
(doseq [[label doc id cut] [["lane clip" (document) :a 2]
["ordinary placement" (ordinary-document) :badge 6]]]
(testing label
(let [before (drawn doc (range 12))
r (span/split doc :main id cut :right)
after (:clip r)]
(is (= :right (:selection r)))
(is (= before (drawn after (range 12))))
(is (= cut
(second (node/placed-span (get-in after [:symbols :main :nodes id])))
(first (node/placed-span (get-in after [:symbols :main :nodes :right])))))
(is (empty? (clip/problems after)))))))
(deftest split-refuses-an-edge-a-missing-node-and-a-spanless-node
(let [doc (document)]
(is (empty? (clip/problems doc)))
(is (nil? (:parent (get-in doc [:symbols :main :nodes :badge])))
"so a command acting on it has only the symbol's frames to go by")
(is (= [2 10] (node/placed-span (get-in doc [:symbols :main :nodes :badge]))))))
;; ---------------------------------------------------------------------------
;; split
(deftest splitting-changes-nothing-that-is-drawn
(let [doc (document)
fs (range 12)
before (drawn doc fs)]
(doseq [[label id cut] [["a held drawing in a lane" :a 2]
["a playing insert in a lane" :insert 10]
["a placement with no lane at all" :badge 6]]]
(testing label
(let [r (span/split doc :main id cut :right)
after (:clip r)]
(is (= :right (:selection r)))
(is (= before (drawn after fs)) "the same picture, frame for frame")
(is (= (node/placed-span (get-in doc [:symbols :main :nodes id]))
[(first (node/placed-span (get-in after [:symbols :main :nodes id])))
(second (node/placed-span (get-in after [:symbols :main :nodes :right])))])
"the pieces occupy the frames the one node did")
(is (= cut (second (node/placed-span (get-in after [:symbols :main :nodes id])))
(first (node/placed-span (get-in after [:symbols :main :nodes :right])))))
(is (= (:time (get-in doc [:symbols :main :nodes id]))
(:time (get-in after [:symbols :main :nodes :right])))
"one time map, so the right piece's own frames carry on")
(is (= (select-keys (get-in doc [:symbols :main :nodes id])
[:source :playback :channels :parent :z])
(select-keys (get-in after [:symbols :main :nodes :right])
[:source :playback :channels :parent :z]))
"and it keeps its parent and its depth, so it draws where it drew")
(is (= 12 (get-in after [:symbols :main :frames])) "and no shot-length question")
(is (empty? (clip/problems after))))))))
(deftest split-refuses-anything-but-one-cut-inside-one-thing
(let [doc (document)]
(doseq [cut [0 4 8 12 -1 2.5 ##NaN nil]]
(is (:refused (span/split doc :main :b cut :right)) (str "cut at " (pr-str cut))))
(is (:refused (span/split doc :main :a 2 :b)) "the new ID has to be free")
(doseq [cut [0 4 -1 2.5 ##NaN nil]]
(is (:refused (span/split doc :main :a cut :right))))
(is (:refused (span/split doc :main :missing 2 :right)))
(is (re-find #"group" (:refused (span/split doc :main :girl 2 :right)))
"a group is divided by its children, not by its span")
(is (re-find #"whole shot" (:refused (span/split doc :main :plate 2 :right)))
"and a node with no span has no edges to cut")))
(is (re-find #"whole shot" (:refused (span/split doc :main :plate 2 :right))))))
;; ---------------------------------------------------------------------------
;; trim
(deftest trimming-only-narrows-the-selected-placement
(doseq [[doc id edge to kept] [[(document) :b :out 6 [4 6]]
[(ordinary-document) :badge :in 5 [5 10]]]]
(let [before (get-in doc [:symbols :main :nodes id])
r (span/trim doc :main id edge to)
after (:clip r)]
(is (= id (:selection r)))
(is (= kept (node/placed-span (get-in after [:symbols :main :nodes id]))))
(is (= (dissoc before :span)
(dissoc (get-in after [:symbols :main :nodes id]) :span)))
(is (empty? (clip/problems after))))))
(deftest trimming-narrows-one-thing-and-moves-nothing-else
(let [doc (document)]
(doseq [[label id edge to kept] [["a cel in a lane" :b :out 6 [4 6]]
["a placement outside one" :badge :out 7 [2 7]]
["the front of one outside a lane" :badge :in 5 [5 10]]]]
(testing label
(let [r (span/trim doc :main id edge to)
after (:clip r)]
(is (= kept (node/placed-span (get-in after [:symbols :main :nodes id]))))
(is (= id (:selection r)))
(is (= (select-keys (get-in doc [:symbols :main :nodes id])
[:time :playback :channels :source])
(select-keys (get-in after [:symbols :main :nodes id])
[:time :playback :channels :source]))
"only :span changed")
(is (= [[0 4] [8 12]] (spans after [:a :insert])) "and no neighbour moved")
(is (= 12 (get-in after [:symbols :main :frames])))
(is (empty? (clip/problems after))))))))
(deftest trimming-the-front-does-not-restart-what-is-playing
;; The difference between trimming and slipping, asserted on the node that has
;; no lane: its own frames are where they were, so the frames that survive
;; show exactly what they showed.
(let [doc (document)
before (sample doc [6 7])
after (:clip (span/trim doc :main :badge :in 6))]
(is (= [6 10] (node/placed-span (get-in after [:symbols :main :nodes :badge]))))
(is (= (:playback (get-in doc [:symbols :main :nodes :badge]))
(:playback (get-in after [:symbols :main :nodes :badge]))))
(is (= (get-in before [6 [:badge :mark]])
(get-in (sample after [6]) [6 [:badge :mark]]))
"the same animation on the frames it kept")
(is (nil? (get-in (sample after [5]) [5 [:badge :mark]]))
"and the frames it gave up show nothing of it")))
(deftest trim-refuses-to-lengthen-or-to-land-on-an-edge
(let [doc (document)]
(doseq [[label id edge to] [["at its own start" :b :in 4]
["at its own end" :b :out 8]
["past its end" :b :out 9]
["before its start" :b :in 2]
["off a whole frame" :b :out 5.5]
["past the end of one outside a lane" :badge :out 11]
["before the start of one outside a lane" :badge :in 1]]]
(is (:refused (span/trim doc :main id edge to)) label))
(is (:refused (span/trim doc :main :b :middle 6)))
(is (re-find #"group" (:refused (span/trim doc :main :girl :out 6))))))
(deftest timeline-edge-resize-allows-an-ordinary-clip-to-grow
(let [after (:clip (span/resize-out (document) :main :badge 11))]
(deftest resizing-an-ordinary-placement-may-overlap
(let [doc (ordinary-document)
after (:clip (span/resize-out doc :main :badge 11 {}))]
(is (= [2 11] (node/placed-span (get-in after [:symbols :main :nodes :badge]))))
(is (:refused (span/resize-out (document) :main :badge 2)))))
(is (:refused (span/resize-out doc :main :badge 2 {})))))
;; ---------------------------------------------------------------------------
;; move
(deftest moving-follows-the-symbol-mode
(let [lane (document)
ordinary (ordinary-document)]
(is (:refused (span/move lane :main :insert 6)) "a lane clip cannot overlap B")
(let [after (:clip (span/move ordinary :main :badge 0))]
(is (= [0 8] (node/placed-span (get-in after [:symbols :main :nodes :badge])))
"an ordinary symbol is free to composite over occupied frames")
(is (empty? (clip/problems after))))))
(deftest moving-keeps-its-length-and-its-source-origin
(let [doc (update-in (document) [:symbols :main :nodes] dissoc :b)
r (span/move doc :main :insert 4)
after (:clip r)]
(is (= [[0 4] [4 8]] (spans after [:a :insert])))
(is (= :insert (:selection r)))
(is (= (:playback (get-in doc [:symbols :main :nodes :insert]))
(:playback (get-in after [:symbols :main :nodes :insert]))))
;; It began on source frame 3 at lane 8; it begins on source frame 3 at lane 4.
(is (= (get-in (sample doc [8]) [8 [:insert :mark]])
(get-in (sample after [4]) [4 [:insert :mark]])))
(deftest clearing-room-then-moving-is-explicit-composition
(let [doc (document)
cleared (:clip (span/blank doc :main [4 8] {}))
after (:clip (span/move cleared :main :insert 4))]
(is (= [4 8] (node/placed-span (get-in after [:symbols :main :nodes :insert]))))
(is (empty? (clip/problems after)))))
(deftest a-move-outside-a-lane-is-free-to-land-on-an-occupied-frame
;; The non-overlap rule is the LANE's, and `:badge` is not in one. Things
;; placed in a composition are allowed to be on screen together, so there is
;; nothing here for a move to refuse.
(let [doc (document)
r (span/move doc :main :badge 0)
after (:clip r)]
(is (= [0 8] (node/placed-span (get-in after [:symbols :main :nodes :badge]))))
(is (= [[0 4] [4 8] [8 12]] (spans after [:a :b :insert]))
"and the lane beside it did not notice")
(is (= (get-in (sample doc [2]) [2 [:badge :mark]])
(get-in (sample after [0]) [0 [:badge :mark]]))
"its source origin came with it")
(is (empty? (clip/problems after)))))
(deftest a-move-onto-an-occupied-frame-of-a-lane-is-refused-rather-than-rippled
(let [doc (document)]
(is (:refused (span/move doc :main :insert 6)) "it would overlap B")
(is (:refused (span/move doc :main :insert 4.5)))
(is (re-find #"group" (:refused (span/move doc :main :girl 2))))
(is (re-find #"whole shot" (:refused (span/move doc :main :plate 2))))
;; Clearing the room first is the composition, and then it goes.
(let [cleared (:clip (lane/blank doc :main :girl [4 8] {}))]
(is (= [[0 4] [4 8]] (spans (:clip (span/move cleared :main :insert 4))
[:a :insert]))))))
;; ---------------------------------------------------------------------------
;; the coordinate
(deftest host-frame-reads-lane-time-for-a-cel-and-symbol-time-for-everything-else
(let [doc (document)
retimed (assoc-in doc [:symbols :main :nodes :girl :time] {:at 4 :rate 2})]
(is (= 6 (span/host-frame doc :main :b 6))
"an untimed lane reads the symbol's frames as its own")
(is (= 6 (span/host-frame doc :main :badge 6))
"and so does a node with no parent, always")
(is (= 4 (span/host-frame retimed :main :b 6))
"through a lane at :at 4 :rate 2, symbol frame 6 is lane frame 4")
(is (= 6 (span/host-frame retimed :main :badge 6))
"which is the lane's business and not the badge's")
(is (nil? (span/host-frame (assoc-in doc [:symbols :main :nodes :girl :time]
{:loop? true})
:main :b 6))
"and a looping parent has no single answer to give")))
(deftest host-frame-of-a-parentless-clip-is-the-symbol-frame
(is (= 6 (span/host-frame (document) :main :b 6)))
(is (= 6 (span/host-frame (ordinary-document) :main :badge 6))))

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

@ -1,28 +1,53 @@
(ns arthur.events.lane-test
(:require [cljs.test :refer [deftest is]]
[arthur.domain.lane-test :as fixture]
[arthur.domain.clip :as clip]
[arthur.domain.correction :as correction]
[arthur.domain.lane :as lane]
[arthur.events.ui :as ui]
[arthur.domain.history :as history]
[arthur.domain.leaf :as leaf]
[arthur.domain.symbol :as symbol]
[arthur.domain.sequence-test :as fixture]
[arthur.domain.span :as span]
[arthur.events.ui :as ui]
[arthur.footage.store :as store]
[arthur.ui.timeline :as timeline]))
[arthur.ui.timeline :as timeline]
[re-frame.core :as rf]
[re-frame.db :as rf-db]))
(deftest one-row-projects-all-cels-and-keeps-selection-addresses
(deftest symbol-and-lane-creation-are-distinct-explicit-commands
(letfn [(run [event key]
(let [doc (clip/blank)
id (store/install! {:clip doc :store {}} key)]
(reset! rf-db/app-db {:clip/current id :paint/revision 0
:ui {:open :main} :playback {:frame 0}})
(rf/dispatch-sync event)
(let [db @rf-db/app-db
saved (:clip (store/entry id))
[_ _ instance-id] (get-in db [:ui :selection])
sid (get-in saved [:symbols :main :nodes instance-id :source :symbol])]
{:db db :symbol (clip/symbol saved sid)})))]
(let [{ordinary :symbol} (run [::ui/new-symbol :inside] "explicit-symbol")
{lane :symbol lane-db :db} (run [::ui/new-lane] "explicit-lane")]
(is (nil? (:display ordinary)) "new symbol means ordinary symbol")
(is (= :lane (:display lane)) "only the lane command creates a lane")
(is (some? (get-in lane-db [:ui :target]))
"the new lane is aimed so drawing and pool drops can go into it"))))
(deftest an-explicit-lane-is-one-row-of-clips
(let [doc (fixture/document)
rows (timeline/rows doc :main #{})
lane (first (filter :cels rows))]
(is (= 2 (count rows)))
lane (first (filter :lane? rows))]
(is (= 2 (count rows)) "the lane row plus the span-less plate")
(is (= [[0 4] [4 8] [8 12]] (mapv :span (:cels lane))))
(is (= [[:node :main :a [:a]] [:node :main :b [:b]] [:node :main :insert [:insert]]]
(mapv :select (:cels lane))))
(is (= [0 6 12] (:keys lane)))
(is (= 1 (count (filter :cels (timeline/rows doc :main #{[:girl]})))))))
(is (= [[:node :main :a [:a]]
[:node :main :b [:b]]
[:node :main :insert [:insert]]]
(mapv :select (:cels lane))))))
(deftest a-nested-selection-converts-the-open-playhead-to-its-owning-symbol
(deftest an-ordinary-symbol-keeps-a-row-per-node
(let [doc (update-in (fixture/document) [:symbols :main] dissoc :display)
rows (timeline/rows doc :main #{})]
(is (empty? (filter :lane? rows)))
(is (= #{[:a] [:b] [:insert] [:plate]} (set (map :path rows))))))
(deftest a-nested-selection-converts-the-open-playhead-to-its-owner
(let [doc (assoc-in (fixture/document) [:symbols :outer]
{:id :outer :frames 30
:nodes {:take {:id :take :kind :instance :z "a"
@ -34,189 +59,59 @@
(is (= 12 (ui/selection-frame doc nil :main
[:node :main :a [:a]] 12)))))
(deftest polygon-landing-follows-the-target-not-the-selection
(let [doc (fixture/document)
db {:ui {:open :main
:selection [:node :main :plate [:plate]]
:target {:sid :main :id :insert :path [:insert]}}
:playback {:frame 5}}
landing (ui/polygon-landing doc {} db)]
(is (= doc (:clip landing)))
(is (= [:insert] (:path landing))
"looking at another shape does not silently move the creation target")
(is (false? (:lane? landing)))))
(deftest polygon-landing-obeys-the-destination-symbol-mode
(let [lane (fixture/document)
ordinary (update-in lane [:symbols :main] dissoc :display)
db {:ui {:open :main :target {:sid :main :id :plate :path [:plate]}}
:playback {:frame 5}}]
(is (true? (:lane? (ui/polygon-landing lane {} db))))
(is (false? (:lane? (ui/polygon-landing ordinary {} db))))))
(deftest timeline-polygon-landing-is-decided-by-the-aimed-lane
(let [doc (fixture/document)
base {:ui {:open :main
:selection [:node :main :plate [:plate]]
:target {:sid :main :id :girl :path [:girl]}}
:playback {:frame 5}}
occupied (ui/polygon-landing doc {} base)
with-gap (:clip (lane/blank doc :main :girl [5 7] {:id :rest}))
gap (ui/polygon-landing with-gap {} (assoc-in base [:playback :frame] 6))]
(is (= [:b] (:path occupied))
"the cel on screen wins even while an unrelated stage node is selected")
(is (= doc (:clip occupied)) "an existing cel needs no document edit")
(is (true? (:lane? occupied)))
(is (= 1 (count (:path gap))))
(is (not (contains? (get-in with-gap [:symbols :main :nodes])
(first (:path gap))))
"a gap receives a fresh drawing")
(is (contains? (get-in (:clip gap) [:symbols :main :nodes])
(first (:path gap))))
(is (empty? (clip/problems (:clip gap))))))
(deftest polygon-landing-without-an-aimed-lane-uses-the-ordinary-target
(let [doc (fixture/document)
db {:ui {:open :main
:target {:sid :main :id :plate :path [:plate]}}
:playback {:frame 5}}
landing (ui/polygon-landing doc {} db)]
(is (= doc (:clip landing)))
(is (= [] (:path landing)))
(is (false? (:lane? landing)))))
(deftest beginning-a-polygon-materializes-a-missing-timeline-drawing
(let [doc (fixture/document)
with-gap (:clip (lane/blank doc :main :girl [5 7] {:id :rest}))
id (store/install! {:clip with-gap :store {}} "polygon-start-test")
db {:clip/current id :paint/revision 0
:ui {:open :main
:target {:sid :main :id :girl :path [:girl]}}
:playback {:frame 6}}
after (ui/beginning-polygon db)
saved (:clip (store/entry (:clip/current after)))
[_ sid cel-id path] (get-in after [:ui :selection])]
(is (= :polygon (get-in after [:ui :tool])))
(is (= [] (get-in after [:ui :draft])))
(is (= :main sid))
(is (= [cel-id] path))
(is (contains? (get-in saved [:symbols :main :nodes]) cel-id)
"the drawing exists before the first draft point is added")
(is (= 6 (get-in saved [:symbols :main :nodes cel-id :time :at])))
(is (empty? (clip/problems saved)))))
(deftest beginning-a-polygon-does-not-invent-an-unselected-lane
(deftest beginning-a-polygon-does-not-invent-a-lane
(let [doc (clip/blank)
id (store/install! {:clip doc :store {}} "polygon-lane-start-test")
id (store/install! {:clip doc :store {}} "polygon-no-implicit-lane")
db {:clip/current id :paint/revision 0
:ui {:open :main}
:playback {:frame 6}}
after (ui/beginning-polygon db)
saved (:clip (store/entry (:clip/current after)))
lanes (symbol/lanes (get-in saved [:symbols :main :nodes]))]
saved (:clip (store/entry (:clip/current after)))]
(is (= :polygon (get-in after [:ui :tool])))
(is (= [:lane] (mapv :id lanes))
"the lane the symbol was born with, and no second one invented here")
(is (empty? (symbol/lane-clips (get-in saved [:symbols :main :nodes]) :lane))
"and nothing put in it")
(is (nil? (get-in after [:ui :target])))
(is (nil? (get-in (store/entry (:clip/current after)) [:history :done])))
(is (empty? (clip/problems saved)))))
(is (= {} (get-in saved [:symbols :main :nodes])))
(is (nil? (get-in saved [:symbols :main :display])))
(is (nil? (get-in (store/entry (:clip/current after)) [:history :done])))))
(deftest sequence-commands-use-isolated-history-transactions
(let [doc (fixture/document)
id (store/install! {:clip doc :store {}} "sequence-test")
id (store/install! {:clip doc :store {}} "sequence-command-test")
db {:clip/current id :paint/revision 0
:ui {:open :main :selection [:node :main :a [:a]]}}
refused (ui/apply-lane-command db :main
(lane/extend-hold doc :main :a 1 {}) [:retry])]
refused (ui/apply-command db :main
(span/extend-hold doc :main :a 1 {}) [:retry])]
(is (= doc (:clip (store/entry id))))
(is (nil? (:history (store/entry id))))
(is (= [:retry] (get-in refused [:ui :lane-retry])))
(let [r1 (lane/extend-hold doc :main :a 1 {:extent :grow-symbol})
db1 (ui/apply-lane-command db :main r1 nil)
r2 (lane/extend-hold (:clip r1) :main :a 1 {:extent :grow-symbol})
db2 (ui/apply-lane-command db1 :main r2 nil)
(is (= [:retry] (get-in refused [:ui :retry])))
(let [r1 (span/extend-hold doc :main :a 1 {:extent :grow-symbol})
db1 (ui/apply-command db :main r1 nil)
r2 (span/extend-hold (:clip r1) :main :a 1 {:extent :grow-symbol})
db2 (ui/apply-command db1 :main r2 nil)
h (:history (store/entry id))
undo (history/undo h (leaf/leaves "u" (:clip r2)))
undo2 (history/undo (:history undo) (:leaves undo))]
(is (= 2 (count (:done h))) "rapid button presses remain separate commands")
(is (= 2 (count (:done h))))
(is (= (:clip r1) (leaf/clip "u" (:leaves undo))))
(is (= doc (leaf/clip "u" (:leaves undo2))))
(is (= [:node :main :a [:a]] (get-in db2 [:ui :selection]))))))
(deftest a-correction-is-one-step-and-keeps-the-full-selection-address
(deftest an-expanded-lane-opens-the-selected-clip
(let [doc (fixture/document)
id (store/install! {:clip doc :store {}} "correction-event-test")
selection [:node :main :a [:outer :a]]
db {:clip/current id :paint/revision 0
:ui {:open :outer :selection selection}}
result (correction/add doc :main :a [:xform :rot]
{:id :nudge :support [0 3] :motion :return
:start 0 :peak 0.5 :peak-frame 1})
after (ui/apply-correction-command db result)
entry (store/entry id)]
(is (= selection (get-in after [:ui :selection])))
(is (= 1 (count (get-in entry [:history :done]))))
(is (= 0.5 (get-in (:clip entry)
[:symbols :main :nodes :a :channels [:xform :rot]
:over 0 :values :keys 1])))
(let [refused (ui/apply-correction-command after {:refused "nope"})]
(is (= "nope" (get-in refused [:project :status])))
(is (= 1 (count (get-in (store/entry id) [:history :done])))))))
rows (timeline/rows doc :main #{[:arthur.ui.timeline/lane] [:insert]} [:insert])
portal (first (filter :portal? rows))]
(is (= [:insert] (:path portal)))
(is (= [:node :main :insert [:insert]] (:select portal)))
(is (some #{"mark"} (map :label rows)))))
(deftest an-expanded-lane-opens-the-selected-clip-and-everything-under-it
;; The whole document is editable from the root timeline: a lane opens one
;; portal — the clip selected in it — and that portal opens the lanes and
;; nodes of the symbol it places, mapped into this ruler.
(let [doc (fixture/document)
open #{[:girl] [:insert]}
shut (timeline/rows doc :main open [:insert])
of (fn [rows] (mapv (juxt :label :depth) rows))
lane-row (first (filter :cels (timeline/rows doc :main open [:insert])))]
(is (= 1 (count (filter :portal? shut)))
"exactly one clip is opened, not one branch per clip in the lane")
(is (= [:insert] (:path (first (filter :portal? shut))))
"and it is the selected one")
(is (some #{["mark" 2]} (of shut))
"the clip's own symbol appears under it, at its depth")
(is (= [:node :main :insert [:insert]]
(:select (first (filter :portal? shut))))
"the portal addresses the same clip its block in the lane does")
(is (= (:keys (second (:cels lane-row)))
(:keys (first (filter #(= [:b] (:path %)) (timeline/rows doc :main open [:b])))))
"a clip's keys are on its block whether or not its portal is open")))
(deftest a-nested-selection-keeps-the-portal-that-revealed-it-open
;; Clicking a shape inside the clip — or the end of its span — is still
;; working inside that clip. Matching the selected id alone would close the
;; portal the moment anything under it was touched.
(let [doc (fixture/document)
open #{[:girl] [:insert]}
deep (timeline/rows doc :main open [:insert :mark])
none (timeline/rows doc :main open [:plate])]
(is (= [:insert] (:path (first (filter :portal? deep))))
"a selection under the clip keeps that clip's portal")
(is (empty? (filter :portal? none)))
(is (some #{"select a clip to inspect"} (map :label none))
"with nothing selected in it, an open lane says what it is waiting for")))
(deftest a-held-clip-shows-its-contents-without-inventing-frames-for-them
;; `clip/source-time` is nil for a hold, so nested keys have no place on this
;; ruler — but the drawing's own nodes must still be reachable from here.
(let [doc (fixture/document)
rows (timeline/rows doc :main #{[:girl] [:a]} [:a])
inside (filter :unmapped? rows)]
(is (seq inside) "a held drawing opens")
(is (some #{"mark"} (map :label inside)))
(is (every? (comp empty? :keys) inside)
"no key is placed where the hold cannot say it belongs")
(is (= [[0 4]] (distinct (keep :span (filter #(= :node (:kind %)) inside))))
"its rows span the hold, which is when it is on screen")))
(deftest a-lane-of-sounds-is-drawn-as-a-lane-and-not-flattened-twice
(let [made (lane/add-lane (fixture/document) :main :track)
seeded (clip/place-sound (:clip made) :main {:sound "s1"} "voice" 6 1 2 :vo)
doc (:clip (lane/adopt seeded :main :track :vo 2 {:extent :grow-symbol}))
picture (remove :sound? (timeline/rows doc :main #{} nil))
sound-lanes (filter :sound? (timeline/rows doc :main #{} nil))
flattened (timeline/sound-rows doc :main #{})]
(is (= 1 (count sound-lanes)) "the sound's lane is one row, like any lane")
(is (= [:vo] (mapv :id (:cels (first sound-lanes))))
"with the sound on it as a block that can be moved and trimmed")
(is (empty? (filter #(= [:track] (:path %)) picture))
"and it is not also listed among the picture rows")
(is (empty? flattened)
"nor flattened into a second, parallel audio row")))
(deftest a-lane-of-sounds-is-not-flattened-twice
(let [base (:clip (span/draw-as-lane (clip/blank) :main true {}))
doc (clip/place-sound base :main {:sound "s1"} "voice" 6 1 2 :vo)
lane (first (filter :lane? (timeline/rows doc :main #{} nil)))]
(is (= [:vo] (mapv :id (:cels lane))))
(is (empty? (timeline/sound-rows doc :main #{})))))

444
frontend/test/browser/lane.mjs
View file

@ -1,5 +1,5 @@
// Local editor smoke test. Uses the in-memory blank document and disables the
// project route, so it never creates an account, project, or server-side write.
// Browser smoke test for the explicit-lane workflow. It uses the in-memory
// document and disables project routing, so it performs no server-side write.
import { spawn } from 'node:child_process';
import { mkdtempSync, rmSync } from 'node:fs';
import { tmpdir } from 'node:os';
@ -7,7 +7,7 @@ import { join } from 'node:path';
import assert from 'node:assert/strict';
const url = process.env.ARTHUR_URL ?? 'http://localhost:8778/';
const profile = mkdtempSync(join(tmpdir(), 'arthur-sequence-'));
const profile = mkdtempSync(join(tmpdir(), 'arthur-explicit-lane-'));
const port = 9335;
const chrome = spawn(process.env.CHROME ?? '/usr/bin/chromium', [
'--headless=new', '--no-sandbox', '--disable-gpu', '--no-first-run',
@ -16,6 +16,7 @@ const chrome = spawn(process.env.CHROME ?? '/usr/bin/chromium', [
], { stdio: 'ignore' });
const sleep = ms => new Promise(resolve => setTimeout(resolve, ms));
let ws;
try {
let target;
for (let i = 0; i < 100 && !target; i++) {
@ -23,11 +24,12 @@ try {
try {
target = (await fetch(`http://127.0.0.1:${port}/json/list`).then(r => r.json()))
.find(t => t.type === 'page' && t.url.startsWith(url));
} catch { /* browser starting */ }
} catch { /* Chromium is still starting. */ }
}
assert(target, 'browser exposes the editor page');
ws = new WebSocket(target.webSocketDebuggerUrl);
await new Promise((resolve, reject) => { ws.onopen = resolve; ws.onerror = reject; });
let serial = 0;
const pending = new Map();
const errors = [];
@ -35,10 +37,10 @@ try {
const msg = JSON.parse(data);
if (msg.method === 'Runtime.exceptionThrown') errors.push(msg.params.exceptionDetails);
if (msg.id && pending.has(msg.id)) {
const { resolve, reject } = pending.get(msg.id);
const waiting = pending.get(msg.id);
pending.delete(msg.id);
if (msg.error) reject(new Error(JSON.stringify(msg.error)));
else resolve(msg.result);
if (msg.error) waiting.reject(new Error(JSON.stringify(msg.error)));
else waiting.resolve(msg.result);
}
};
const send = (method, params = {}) => new Promise((resolve, reject) => {
@ -47,13 +49,16 @@ try {
ws.send(JSON.stringify({ id, method, params }));
});
const evaluate = async expression => {
const r = await send('Runtime.evaluate', { expression, returnByValue: true, awaitPromise: true });
if (r.exceptionDetails) throw new Error(JSON.stringify(r.exceptionDetails));
return r.result.value;
const result = await send('Runtime.evaluate', {
expression, returnByValue: true, awaitPromise: true,
});
if (result.exceptionDetails) throw new Error(JSON.stringify(result.exceptionDetails));
return result.result.value;
};
await send('Runtime.enable');
for (let i = 0; i < 100; i++) {
if (await evaluate('typeof arthur !== "undefined" && !!arthur.events?.ui && !!document.querySelector("canvas.stage")')) break;
if (await evaluate('typeof arthur !== "undefined" && !!document.querySelector("canvas.stage")')) break;
await sleep(100);
}
await evaluate(`(() => {
@ -61,342 +66,145 @@ try {
cljs.core.swap_BANG_(re_frame.db.app_db, db => cljs.core.assoc(db, k('route'), k('local-test')));
window.laneSnapshot = () => {
const db = cljs.core.deref(re_frame.db.app_db);
const entry = arthur.footage.store.entry(cljs.core.get(db, k('clip/current')));
return cljs.core.clj__GT_js(entry);
return cljs.core.clj__GT_js(arthur.footage.store.entry(cljs.core.get(db, k('clip/current'))));
};
return true;
})()`);
await sleep(250);
// A command is named the same wherever it is drawn, and since the transport
// strip was consolidated it is drawn in one of two places: as a button in the
// strip, or as a row in one of the strip's menus. So the test asks for it by
// name and this finds it — opening each menu in turn to look — rather than the
// test knowing which menu anything ended up in. An icon button is matched on
// its `aria-label`, which is also what a screen reader is told it is.
// Two bars carry commands: the location bar says where an edit lands and holds
// what creates things there, the transport strip holds what acts on a cel.
const bars = ['.loc', '.pane.time .pane-head', '.section'];
const within = (suffix) => bars.map((b) => `${b} ${suffix}`).join(', ');
const named = label =>
`(b => b.textContent.trim() === ${JSON.stringify(label)}` +
` || b.getAttribute('aria-label') === ${JSON.stringify(label)})`;
const shut = async () => {
await evaluate(`(() => { document.querySelectorAll('.menu-scrim').forEach(s => s.click()); return true })()`);
await sleep(120);
const named = label => `(b => b.getAttribute('aria-label') === ${JSON.stringify(label)}` +
` || b.textContent.trim() === ${JSON.stringify(label)})`;
const closeMenus = async () => {
await evaluate(`(() => { document.querySelectorAll('.menu-scrim').forEach(x => x.click()); return true })()`);
await sleep(80);
};
// Leaves the control on screen and returns what to select it with.
const reveal = async label => {
await shut();
if (await evaluate(`![...document.querySelectorAll('${within('button')}')].find(${named(label)})`)) {
const menus = await evaluate(
`[...document.querySelectorAll('${within('.menu-wrap > button')}')].map(b => b.textContent.trim())`);
let found = false;
for (const menu of menus) {
await evaluate(`(() => { [...document.querySelectorAll('${within('.menu-wrap > button')}')]
.find(b => b.textContent.trim() === ${JSON.stringify(menu)}).click(); return true })()`);
await sleep(180);
if (await evaluate(`!![...document.querySelectorAll('.menu-item')].find(${named(label)})`)) { found = true; break; }
await shut();
}
assert(found, `a control named: ${label}`);
return '.menu-item';
}
return within('button');
};
const click = async label => {
const where = await reveal(label);
const clickNew = async label => {
await closeMenus();
assert(await evaluate(`(() => {
const b = [...document.querySelectorAll('${where}')].find(${named(label)});
if (!b || b.disabled) return false;
b.click(); return true;
})()`), `enabled control: ${label}`);
await sleep(180);
await shut();
const menu = document.querySelector('.loc .menu-wrap > button');
if (!menu) return false;
menu.click(); return true;
})()`), 'new menu exists');
await sleep(100);
assert(await evaluate(`(() => {
const item = [...document.querySelectorAll('.menu-item')].find(${named(label)});
if (!item || item.disabled) return false;
item.click(); return true;
})()`), `enabled creation command: ${label}`);
await sleep(220);
await closeMenus();
};
// UUIDs expose a mutable hash cache through clj->js; compare their identity,
// not that implementation detail, when asserting exact undo restoration.
const shot = async () => JSON.parse(JSON.stringify(await evaluate('laneSnapshot()'),
(_key, value) => value?.uuid ?? value));
const instances = s => Object.values(s.clip.symbols.main.nodes)
.filter(n => n.kind === 'instance')
.sort((a, b) => a.time.at - b.time.at);
const placed = s => instances(s).map(n => [
n.time.at + n.span[0] / (n.time.rate ?? 1),
n.time.at + n.span[1] / (n.time.rate ?? 1),
]);
const key = async (key, extra = {}) => {
await send('Input.dispatchKeyEvent', {type: 'keyDown', key, ...extra});
await send('Input.dispatchKeyEvent', {type: 'keyUp', key, ...extra});
await sleep(180);
};
const undo = () => key('z', {modifiers: 2});
const drag = async (selector, df, {zone = 0.5, shift = false} = {}) => {
const points = await evaluate(`(() => {
const handle = document.querySelector(${JSON.stringify(selector)});
if (!handle) return null;
const track = handle.closest('.tl-track');
const h = handle.getBoundingClientRect();
const t = track.getBoundingClientRect();
const frames = Number(document.querySelector('.at-frame').textContent.split('/')[1]);
const x = h.left + h.width * ${zone};
const y = h.top + h.height / 2;
return {x, y, end: x + t.width * ${df} / frames};
})()`);
assert(points, `drag handle exists: ${selector}`);
const modifiers = shift ? 8 : 0;
await send('Input.dispatchMouseEvent', {
type: 'mousePressed', x: points.x, y: points.y,
button: 'left', buttons: 1, clickCount: 1, modifiers,
});
await sleep(100);
await send('Input.dispatchMouseEvent', {
type: 'mouseMoved', x: points.end, y: points.y,
button: 'left', buttons: 1, modifiers,
});
await sleep(100);
await send('Input.dispatchMouseEvent', {
type: 'mouseReleased', x: points.end, y: points.y,
button: 'left', buttons: 0, clickCount: 1, modifiers,
});
await sleep(250);
};
const tabs = () => evaluate(`(() => {
const k = cljs.core.keyword, db = cljs.core.deref(re_frame.db.app_db);
return {tabs: cljs.core.clj__GT_js(cljs.core.get_in(db, [k('ui'), k('tabs')])).map(String),
open: String(cljs.core.clj__GT_js(cljs.core.get_in(db, [k('ui'), k('open')])))};
})()`);
// A real two-press double-click, not `.dispatchEvent`: what broke here was
// where the browser decides to deliver the click, which a synthetic event
// cannot show.
const doubleClick = async selector => {
const p = await evaluate(`(() => {
const el = document.querySelector(${JSON.stringify(selector)});
if (!el) return null;
const r = el.getBoundingClientRect();
return {x: r.left + r.width / 2, y: r.top + r.height / 2};
})()`);
assert(p, `something to double-click: ${selector}`);
for (const clickCount of [1, 2]) {
await send('Input.dispatchMouseEvent', {type: 'mousePressed', x: p.x, y: p.y,
button: 'left', buttons: 1, clickCount});
await send('Input.dispatchMouseEvent', {type: 'mouseReleased', x: p.x, y: p.y,
button: 'left', buttons: 0, clickCount});
await sleep(60);
}
await sleep(280);
};
const dropPoolSymbol = async frame => {
const points = await evaluate(`(() => {
const source = document.querySelector('.pool-row:not(.main) .pool-item[draggable="true"]');
const track = document.querySelector('.tl-track');
if (!source || !track) return null;
source.scrollIntoView({block: 'center'});
const a = source.getBoundingClientRect(), b = track.getBoundingClientRect();
const frames = Number(document.querySelector('.at-frame').textContent.split('/')[1]);
return {sx: a.left + a.width / 2, sy: a.top + a.height / 2,
tx: b.left + b.width * (${frame} + 0.25) / frames,
ty: b.top + b.height / 2};
})()`);
assert(points, 'a library symbol and lane are available to drag');
await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: points.sx, y: points.sy});
await send('Input.dispatchMouseEvent', {type: 'mousePressed', x: points.sx, y: points.sy,
button: 'left', buttons: 1, clickCount: 1});
await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: points.sx + 12, y: points.sy,
button: 'left', buttons: 1});
await sleep(120);
await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: points.tx, y: points.ty,
button: 'left', buttons: 1});
await sleep(120);
assert.equal(await evaluate('document.querySelectorAll(".tl-label.ghost").length'), 0,
'targeting an existing lane does not preview a temporary new row');
const lanePreview = await evaluate(`(() => {
const db = cljs.core.deref(re_frame.db.app_db), k = cljs.core.keyword;
return {ghosts: document.querySelectorAll('.tl-track .tl-cel.ghost').length,
drop: cljs.core.clj__GT_js(cljs.core.get_in(db, [k('ui'), k('drop')]))};
})()`);
assert.equal(lanePreview.ghosts, 1,
`the pool drop preview is drawn inside the targeted lane: ${JSON.stringify(lanePreview)}`);
await send('Input.dispatchMouseEvent', {type: 'mouseReleased', x: points.tx, y: points.ty,
button: 'left', buttons: 0, clickCount: 1});
await sleep(300);
};
const dragClipBetweenLanes = async frame => {
const points = await evaluate(`(() => {
const tracks = [...document.querySelectorAll('.tl-track')];
const source = tracks[1]?.querySelector('.tl-cel');
const target = tracks[0];
if (!source || !target) return null;
const a = source.getBoundingClientRect(), b = target.getBoundingClientRect();
const frames = Number(document.querySelector('.at-frame').textContent.split('/')[1]);
return {sx: a.left + a.width / 2, sy: a.top + a.height / 2,
tx: b.left + b.width * (${frame} + 0.25) / frames,
ty: b.top + b.height / 2};
})()`);
assert(points, 'two lanes and a source clip are available');
await send('Input.dispatchMouseEvent', {type: 'mousePressed', x: points.sx, y: points.sy,
button: 'left', buttons: 1, clickCount: 1});
await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: points.tx, y: points.ty,
button: 'left', buttons: 1});
await sleep(150);
assert.equal(await evaluate('document.querySelectorAll(".tl-track")[0].querySelectorAll(".tl-cel.ghost").length'), 1,
'cross-lane movement previews in the destination lane');
await send('Input.dispatchMouseEvent', {type: 'mouseReleased', x: points.tx, y: points.ty,
button: 'left', buttons: 0, clickCount: 1});
await sleep(300);
};
const mainInstances = s => Object.values(s.clip.symbols.main.nodes)
.filter(n => n.kind === 'instance');
const laneSymbols = s => Object.values(s.clip.symbols).filter(sym => sym.display === 'lane');
assert.equal(await evaluate('[...document.querySelectorAll(".timing-controls > button")].every(b => b.disabled)'), true,
'timing buttons are disabled without a symbol clip');
await click('inside');
assert.equal((await shot()).clip.symbols.main.display, undefined,
'a blank document starts as an ordinary symbol');
await clickNew('inside');
let s = await shot();
assert.deepEqual(placed(s), [[0, 1]],
'new at the root automatically makes a lane and a one-frame symbol clip');
assert.equal(await evaluate('document.querySelectorAll(".tl-label .kind").length'), 1,
'new temporal content creates a lane row rather than a row per symbol');
assert.equal(await evaluate(`document.querySelectorAll('.cel-sheet, [aria-label="time view"]').length`), 0,
'there is one temporal interface');
assert.equal(await evaluate('document.querySelectorAll(".timing-controls > button").length'), 3,
'timing operations are direct buttons');
let placed = mainInstances(s);
assert.equal(placed.length, 1, 'new symbol places one instance');
assert.equal(s.clip.symbols[placed[0].source.symbol].display, undefined,
'new symbol remains ordinary');
assert.equal(await evaluate('document.querySelectorAll(".tl-track").length'), 1,
'an ordinary symbol is an ordinary timeline row');
await drag('.tl-cel .tl-edge.out', 3);
await clickNew('lane');
s = await shot();
assert.deepEqual(placed(s), [[0, 4]], 'a right edge directly changes the endpoint');
placed = mainInstances(s);
assert.equal(placed.length, 2, 'explicit lane places a second symbol');
assert.equal(laneSymbols(s).length, 1, 'only the lane command marks a symbol as a lane');
assert.equal(await evaluate('[...document.querySelectorAll(".tl-track")].filter(t => t.arthurLane).length'), 1,
'the explicit lane is drawn as one linear track');
for (let i = 0; i < 4; i++) await click('+1');
await click('inside');
await drag('.tl-cel:nth-of-type(2) .tl-edge.out', 2);
for (let i = 0; i < 3; i++) await click('+1');
await click('inside');
s = await shot();
assert.deepEqual(placed(s), [[0, 4], [4, 7], [7, 8]]);
await drag('.tl-cel:nth-of-type(2) .tl-junction', 1, {zone: 0.5});
assert.deepEqual(placed(await shot()), [[0, 5], [5, 7], [7, 8]],
'the middle of a junction rolls both edges');
await undo();
await drag('.tl-cel:nth-of-type(2) .tl-junction', 1, {zone: 0.9});
assert.deepEqual(placed(await shot()), [[0, 4], [5, 7], [7, 8]],
'the right side trims only the right clip');
await undo();
await drag('.tl-cel:nth-of-type(2) .tl-junction', -1, {zone: 0.1});
assert.deepEqual(placed(await shot()), [[0, 3], [4, 7], [7, 8]],
'the left side trims only the left clip');
await undo();
await drag('.tl-cel:nth-of-type(2) .tl-edge.out', 2, {shift: true});
assert.deepEqual(placed(await shot()), [[0, 4], [4, 9], [9, 10]],
'Shift-edge ripples every later clip on the lane');
await undo();
await drag('.tl-cel:first-of-type .tl-edge.out', 2);
assert.deepEqual(placed(await shot()), [[0, 6], [6, 7], [7, 8]],
'ordinary growth trims adjacent spans and never overlaps');
await dropPoolSymbol(10);
s = await shot();
assert.deepEqual(placed(s), [[0, 6], [6, 7], [7, 8], [10, 11]],
'an arbitrary library symbol drops into an existing lane');
assert.equal(instances(s).at(-1).playback.speed, 1,
'a dropped symbol plays naturally instead of becoming a held drawing');
await evaluate(`re_frame.core.dispatch(cljs.core.vector(cljs.core.keyword('arthur.events.ui/new-lane')))`);
await sleep(180);
s = await shot();
const renameControls = await evaluate('document.querySelectorAll(".tl-label .tl-rename").length');
assert.equal(renameControls, 2,
`both lanes expose rename controls: ${JSON.stringify(s.clip.symbols.main.nodes)}`);
await evaluate('document.querySelector(".tl-label .tl-rename").click()');
assert.equal(await evaluate('document.querySelectorAll(".tl-rename").length'), 1,
'the lane exposes its rename control');
await evaluate('document.querySelector(".tl-rename").click()');
await sleep(80);
assert(await evaluate(`(() => {
const input = document.querySelector('.tl-name-input');
if (!input) return false;
Object.getOwnPropertyDescriptor(HTMLInputElement.prototype, 'value').set.call(input, 'Foreground');
input.dispatchEvent(new InputEvent('input', {bubbles: true, inputType: 'insertText', data: 'Foreground'}));
Object.getOwnPropertyDescriptor(HTMLInputElement.prototype, 'value')
.set.call(input, 'Foreground');
input.dispatchEvent(new InputEvent('input', {bubbles: true, inputType: 'insertText'}));
input.blur(); return true;
})()`), 'lane rename editor opens');
await sleep(180);
s = await shot();
assert(Object.values(s.clip.symbols.main.nodes).some(n => n.layout === 'sequence' && n.name === 'Foreground'),
'a lane name is editable and persisted in the document');
assert(mainInstances(s).some(n => n.name === 'Foreground'), 'lane name persists');
await dragClipBetweenLanes(12);
s = await shot();
const lanes = Object.values(s.clip.symbols.main.nodes).filter(n => n.layout === 'sequence');
assert.deepEqual(lanes.map(l => instances(s).filter(n => n.parent === l.id).length).sort(), [1, 3],
'a clip body can move from one lane to another');
// EXPANDING A LANE OPENS THE SELECTED CLIP. Its own keys, and under it the
// lanes and nodes of the symbol it places, all on this ruler — which is what
// makes the whole document editable from the root timeline.
const rowLabels = () => evaluate(
`[...document.querySelectorAll('.tl-labels > .tl-label')].map(e => e.textContent.trim())`);
const twist = async i => {
assert(await evaluate(`(() => {
const t = document.querySelectorAll('.tl-labels > .tl-label .tl-twist')[${i}];
if (!t || t.disabled) return false;
t.click(); return true;
})()`), `an expander at row ${i}`);
await sleep(220);
};
await evaluate(`(() => { document.querySelector('.tl-track .tl-cel').click(); return true })()`);
await sleep(200);
const collapsed = await rowLabels();
await twist(0);
const opened = await rowLabels();
assert(opened.length > collapsed.length, 'the lane opens');
assert.equal(opened.filter(l => l.includes('instance')).length, 1,
`one clip portal, not one branch per clip: ${JSON.stringify(opened)}`);
const portalAt = opened.findIndex(l => l.includes('instance'));
await twist(portalAt);
const deep = await rowLabels();
assert(deep.length > opened.length,
`the portal opens the symbol the clip places: ${JSON.stringify(deep)}`);
// Selecting something nested must not close the portal that revealed it.
await evaluate(`(() => {
const k = cljs.core.keyword, db = cljs.core.deref(re_frame.db.app_db);
const sel = cljs.core.get_in(db, [k('ui'), k('selection')]);
const path = cljs.core.nth(sel, 3);
re_frame.core.dispatch(cljs.core.vector(
k('arthur.events.ui/select'),
cljs.core.vector(k('node'), cljs.core.nth(sel, 1), cljs.core.nth(sel, 2),
cljs.core.conj(path, k('made-up-child')))));
return true;
// Drag a library symbol into the explicit lane. The row itself is the target;
// no temporary lane is previewed or created.
const drop = await evaluate(`(() => {
const source = document.querySelector('.pool-row:not(.main) .pool-item[draggable="true"]');
const track = [...document.querySelectorAll('.tl-track')].find(t => t.arthurLane);
if (!source || !track) return null;
source.scrollIntoView({block: 'center'});
const a = source.getBoundingClientRect(), b = track.getBoundingClientRect();
return {sx: a.left + a.width / 2, sy: a.top + a.height / 2,
tx: b.left + b.width * .085, ty: b.top + b.height / 2};
})()`);
await sleep(220);
assert.equal((await rowLabels()).filter(l => l.includes('instance')).length, 1,
'a selection under the clip keeps its portal open');
await twist(portalAt);
await twist(0);
assert(drop, 'a pool symbol and explicit lane are available');
await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: drop.sx, y: drop.sy});
await send('Input.dispatchMouseEvent', {type: 'mousePressed', x: drop.sx, y: drop.sy,
button: 'left', buttons: 1, clickCount: 1});
await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: drop.sx + 12, y: drop.sy,
button: 'left', buttons: 1});
await sleep(100);
await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: drop.tx, y: drop.ty,
button: 'left', buttons: 1});
await sleep(120);
assert.equal(await evaluate('document.querySelectorAll(".tl-label.ghost").length'), 0,
'pool drop does not preview an invented lane');
assert.equal(await evaluate('document.querySelectorAll(".tl-cel.ghost").length'), 1,
'pool drop previews inside the existing lane');
await send('Input.dispatchMouseEvent', {type: 'mouseReleased', x: drop.tx, y: drop.ty,
button: 'left', buttons: 0, clickCount: 1});
await sleep(300);
s = await shot();
assert.equal(Object.keys(laneSymbols(s)[0].nodes).length, 1,
`the dropped clip remains in the explicit lane: ${JSON.stringify(s)}`);
assert.equal(laneSymbols(s).length, 1, 'the drop creates no extra lane');
const before = await tabs();
const tabChips = () => evaluate('document.querySelectorAll(".tabs .tab").length');
const chipsBefore = await tabChips();
await doubleClick('.tl-track .tl-cel');
const after = await tabs();
assert.equal(after.tabs.length, before.tabs.length + 1,
`double-clicking a clip opens the symbol it places, as the pool row does: ${JSON.stringify(after)}`);
assert(!before.tabs.includes(after.open) && after.tabs.includes(after.open),
`the opened symbol is the one in front: ${JSON.stringify(after)}`);
assert.equal(await tabChips(), chipsBefore + 1,
'the opened symbol is drawn as one more tab');
assert.equal(await evaluate('document.querySelectorAll("#app > *").length'), 1,
'opening from the timeline leaves the editor standing: a stale node selection ' +
'pointing into the symbol just left used to throw and unmount it');
// A second explicit lane is a sibling in the open symbol even though the
// first remains aimed. Move the clip between their linear tracks.
await clickNew('lane');
s = await shot();
assert.equal(laneSymbols(s).length, 2, 'a second explicit command creates a second lane');
const move = await evaluate(`(() => {
const tracks = [...document.querySelectorAll('.tl-track')].filter(t => t.arthurLane);
const from = tracks.find(t => t.querySelector('.tl-cel'));
const to = tracks.find(t => t !== from);
const cel = from?.querySelector('.tl-cel');
if (!cel || !to) return null;
const a = cel.getBoundingClientRect(), b = to.getBoundingClientRect();
return {sx: a.left + a.width / 2, sy: a.top + a.height / 2,
tx: b.left + b.width * .12, ty: b.top + b.height / 2};
})()`);
assert(move, 'two explicit lanes and a source clip are available');
await send('Input.dispatchMouseEvent', {type: 'mousePressed', x: move.sx, y: move.sy,
button: 'left', buttons: 1, clickCount: 1});
await send('Input.dispatchMouseEvent', {type: 'mouseMoved', x: move.tx, y: move.ty,
button: 'left', buttons: 1});
await sleep(150);
await send('Input.dispatchMouseEvent', {type: 'mouseReleased', x: move.tx, y: move.ty,
button: 'left', buttons: 0, clickCount: 1});
await sleep(300);
s = await shot();
assert.deepEqual(laneSymbols(s).map(x => Object.keys(x.nodes).length).sort(), [0, 1],
'a clip body moves from one explicit lane to the other');
assert.equal(errors.length, 0, JSON.stringify(errors));
console.log('PASS: generic lanes preview, rename, move, place, open, trim, roll, and ripple clips');
console.log('PASS: symbols are ordinary; explicit lanes rename, accept drops, and exchange clips');
} finally {
if (ws?.readyState === WebSocket.OPEN) {
ws.send(JSON.stringify({ id: 999999, method: 'Browser.close' }));
await sleep(350);
}
ws?.close();
chrome.kill();
await new Promise(resolve => { if (chrome.exitCode !== null || chrome.signalCode !== null) resolve(); else chrome.once('exit', resolve); });
if (ws?.readyState === WebSocket.OPEN) ws.close();
chrome.kill('SIGTERM');
await new Promise(resolve => chrome.once('exit', resolve));
try {
rmSync(profile, { recursive: true, force: true, maxRetries: 5, retryDelay: 100 });
} catch (error) {
console.warn(`Temporary browser profile retained at ${profile}: ${error.code}`);
if (error.code !== 'ENOTEMPTY') throw error;
}
}