Unify lane symbol creation and palette automation

This commit is contained in:
Your Name 2026-10-03 01:35:33 -04:00
parent 15deaea19e
commit a834ccb1e2
13 changed files with 176 additions and 121 deletions

View file

@ -364,7 +364,11 @@
;; Palette-choice channels interpolate identities into a blend
;; descriptor. The renderer keeps indexed geometry in the left
;; palette's bank and blends that bank's ramp toward the right one.
(and (= :palette (:semantic ch)) (keyword? a) (keyword? b))
;; Palette ids are opaque identities. Built-ins happen to use
;; keywords, while palettes made in the editor use UUIDs; treating
;; the latter as numbers produces NaN and therefore the renderer's
;; pink bad-data sentinel.
(and (= :palette (:semantic ch)) (some? a) (some? b))
{:from a :to b :t t}
(vector? a)
(mapv (fn [x y] (+ x (* t (- y x)))) a b)
@ -520,7 +524,7 @@
(let [values (when (map? (:keys ch)) (vals (:keys ch)))
first-value (first values)
linear-values? (or (every? number? values)
(and (= :palette (:semantic ch)) (every? keyword? values))
(and (= :palette (:semantic ch)) (every? some? values))
(and (vector? first-value)
(pos? (count first-value))
(every? (fn [v] (and (vector? v)

View file

@ -264,7 +264,16 @@
;; A palette track has meaningful uncovered time. Ordinary held
;; channels clamp to their first key before it, but doing that
;; here would erase the gap before the first palette segment.
(let [track (:palette-channel owner)
(let [fallback (or (channel-value (:palette owner) frame)
inherited (:default palette))
materialize (fn [choice]
(cond
(= pal/inherit choice) fallback
(map? choice) (-> choice
(update :from #(if (= pal/inherit %) fallback %))
(update :to #(if (= pal/inherit %) fallback %)))
:else choice))
track (:palette-channel owner)
track-value (if-let [ks (:keys track)]
(some->> (keys ks)
(filter #(<= % frame))
@ -286,12 +295,10 @@
choice (get-in palette-clip [:channels [:palette]])
start (some-> palette-clip node/placed-span first)]
(or (when (and choice start)
(channel-value choice (- frame start)))
(materialize (channel-value choice (- frame start))))
fallback)))
track-value
(channel-value (:palette owner) frame)
inherited
(:default palette))))
fallback)))
(selection-at [owner frame inherited]
(let [selection (:palette owner)
chosen (cond

View file

@ -7,6 +7,7 @@
are derived, never persisted: adding a palette never rewrites drawing data.")
(def default-id :arthur/default)
(def inherit :arthur.palette/inherit)
(def entries
[{:name :bg :hex "#12141c"}

View file

@ -730,9 +730,7 @@
(-> []
(cond->
(and (= :palette (:type sym)) (seq nodes))
(conj "a palette symbol cannot contain nodes")
(and (= :palette (:type sym)) (nil? (:palette-ref sym)))
(conj "a palette symbol must point at a palette"))
(conj "a palette symbol cannot contain nodes"))
(into (for [[id n] nodes
:when (not= id (:id n))]
(str "node under key " (pr-str id) " has :id " (pr-str (:id n)))))

View file

@ -729,50 +729,6 @@
(assoc-in % [:symbols sid :palette] id)
(update-in % [:symbols sid] dissoc :palette)))))
(rf/reg-event-db
::drop-palette
(fn [db [_ root-sid frame palette-id]]
(let [{document :clip st :store} (store/entry (:clip/current db))
root (clip/symbol document root-sid)
old-track (:palette-track root)
track-id (if (= :palette-track (get-in document [:symbols old-track :type]))
old-track (clip/fresh-id document))
palette-sid (or (some (fn [[sid sym]]
(when (and (= :palette (:type sym))
(= palette-id (:palette-ref sym))) sid))
(:symbols document))
(clip/fresh-id (cond-> document
(not= track-id old-track)
(assoc-in [:symbols track-id] {}))))
document (cond-> (if (= track-id old-track)
document
(-> document
(assoc-in [:symbols root-sid :palette-track] track-id)
(assoc-in [:symbols track-id]
{:id track-id :name "palette" :type :palette-track
:display :lane :frames (:frames root)
:fps (clip/fps document root-sid) :nodes {}})))
(nil? (clip/symbol document palette-sid))
(assoc-in [:symbols palette-sid]
{:id palette-sid
:name (or (get-in document [:palettes palette-id :name])
(name palette-id))
:type :palette :palette-ref palette-id
:frames 1 :fps (clip/fps document root-sid) :nodes {}}))
id (random-uuid)
result (span/place-symbol document st track-id id palette-sid frame
{:extent :grow-symbol :remainder-id (random-uuid)})
result (if-let [placed (:clip result)]
(assoc result :clip
(assoc-in placed [:symbols track-id :nodes id :channels [:palette]]
(assoc (ch/framed palette-id) :semantic :palette)))
result)]
(if-let [why (:refused result)]
(update db :project merge {:status why})
(-> db
(edit/edit (constantly (:clip result)))
(assoc-in [:ui :selection] [:node track-id id [id]]))))))
(rf/reg-event-db
::set-channel
;; `frame` is the node's own, as for a drawing key.
@ -784,7 +740,7 @@
(if (get-in document [:symbols sid :nodes id :channels [:palette]])
document
(let [source (get-in document [:symbols sid :nodes id :source :symbol])
palette-id (get-in document [:symbols source :palette-ref])]
palette-id (or (get-in document [:symbols source :palette-ref]) pal/inherit)]
(assoc-in document [:symbols sid :nodes id :channels [:palette]]
(assoc (ch/framed palette-id) :semantic :palette)))))

View file

@ -17,12 +17,14 @@
app to change and the most expensive to have two copies of."
(:require [clojure.string :as str]
[arthur.domain.clip :as clip]
[arthur.domain.channel :as ch]
[arthur.domain.clipboard :as clipboard]
[arthur.domain.correction :as correction]
[arthur.domain.creation :as creation]
[arthur.domain.gesture :as gesture]
[arthur.domain.nest :as nest]
[arthur.domain.node :as node]
[arthur.domain.palette :as pal]
[arthur.domain.span :as span]
[arthur.events.edit :as edit]
[arthur.domain.paint :as paint]
@ -793,6 +795,52 @@
(edit/transaction (constantly (:clip result)))
(selected [:node sid uuid (conj (vec path) uuid)]))))
(rf/reg-event-db
::new-symbol-at
;; One gesture and one creation path for every lane. The destination decides
;; the kind: an ordinary lane gets a blank symbol; the synthetic palette row
;; gets a blank palette symbol whose placement starts by inheriting.
(fn [db [_ frame target]]
(let [{document :clip st :store} (store/entry (:clip/current db))
palette? (= :arthur.ui.timeline/palette-track (first target))
root-sid (second target)
root (when palette? (clip/symbol document root-sid))
old-track (:palette-track root)
track-id (when palette?
(if (= :palette-track (get-in document [:symbols old-track :type]))
old-track (clip/fresh-id document)))
document (if (and palette? (not= track-id old-track))
(-> document
(assoc-in [:symbols root-sid :palette-track] track-id)
(assoc-in [:symbols track-id]
{:id track-id :name "palette" :type :palette-track
:display :lane :frames (:frames root)
:fps (clip/fps document root-sid) :nodes {}}))
document)
where (if palette?
{:clip document :sid track-id :at frame :path []}
(drop-destination db document st frame target))
sid (clip/fresh-id document)
uuid (random-uuid)]
(if (:refused where)
(update db :project merge {:status (:refused where)})
(let [seeded (assoc-in document [:symbols sid]
(cond-> {:id sid
:name (if palette? "palette transition" (name sid))
:fps (clip/fps document (:sid where))
:frames 1 :nodes {}}
palette? (assoc :type :palette)))
result (span/place-symbol seeded st (:sid where) uuid sid (:at where)
{:extent :grow-symbol
:remainder-id (random-uuid)})
result (if-let [placed (and palette? (:clip result))]
(assoc result :clip
(assoc-in placed [:symbols (:sid where) :nodes uuid
:channels [:palette]]
(assoc (ch/framed pal/inherit) :semantic :palette)))
result)]
(landed db where uuid result))))))
(rf/reg-event-db
::drop-symbol
;; A symbol dropped on a row becomes a naturally playing clip in the symbol that

View file

@ -47,13 +47,6 @@
:center (clip/center document st sid)
:shapes (outline document st sid)}))))
(defn palette!
"Start carrying a project palette toward the open symbol's palette track."
[id label]
(reset! carrying {:kind :palette :palette id :label label :frames 1}))
(defn palette? [] (= :palette (:kind @carrying)))
(defn accepts?
"Whether the stage or the tracks should accept what is being carried: things
out of the pool, and not one that would make a cycle."
@ -127,10 +120,3 @@
:sound (rf/dispatch [::ui/drop-sound c frame target])
nil))
(done!)))
(defn land-palette!
"Put the carried palette on `sid`'s palette track at `frame`."
[sid frame]
(when-let [{:keys [palette]} (when (palette?) @carrying)]
(rf/dispatch [::project/drop-palette sid frame palette]))
(done!))

View file

@ -268,12 +268,15 @@
:title (if (:keys ch) (str (count (:keys ch)) " keys") "key this here")
:on-click #(rf/dispatch [::project/toggle-palette-key sid id frame])}
"◆"]
[:select {:value (str chosen)
[:select {:value (if (= pal/inherit chosen) "" (str chosen))
:on-change
(fn [e]
(let [v (.. e -target -value)
palette-id (first (filter #(= v (str %)) (keys (pal/palettes clip))))]
palette-id (or (first (filter #(= v (str %))
(keys (pal/palettes clip))))
pal/inherit)]
(rf/dispatch [::project/set-palette-choice sid id frame palette-id])))}
[:option {:value ""} "inherit"]
(for [[palette-id p] palettes]
^{:key (str palette-id)}
[:option {:value (str palette-id)} (:name p)])]]]
@ -735,7 +738,8 @@
;; showing now would move the section under the playhead.
placed (node/source (peek node))
palette-placement? (and node
(= :palette (get-in clip [:symbols placed :type])))
(= :palette-track
(get-in clip [:symbols (first node) :type])))
palette-symbol? (and (= :symbol (first selection))
(= :palette (get-in clip [:symbols (second selection) :type])))
face (or placed (when (trace/traceable? clip open) open))

View file

@ -271,25 +271,6 @@
(carrying (str "symbol:" (subs (str sid) 1))
#(drag/symbol! clip-id sid open)))]))
(defn- palette-row [id p default-id chosen rename]
^{:key (str id)}
[row (merge {:label (:name p)
:sub (str (count (:slots p)) " colors")
:title (str (:name p) " · " (count (:slots p))
" indexed colors — drag onto the palette track")
:thumb [:span.thumb {:style {:display "grid"
:grid-template-columns "repeat(4,1fr)"}}
(for [[i s] (map-indexed vector (take 16 (:slots p)))]
^{:key i} [:i {:style {:background (:hex s)}}])]
:on? (= id chosen)
:rename (assoc rename :key [:palette id] :value (:name p)
:commit! (fn [value]
((:begin! rename) nil)
(rf/dispatch [::project/palette-name id value])))
:on-click #(rf/dispatch [:arthur.ui.palette/select id])
:on-double-click #(rf/dispatch [::project/default-palette id])}
(carrying (str "palette:" id) #(drag/palette! id (:name p))))])
(defn- palette-transition-row [document sid selection rename]
(let [sym (clip/symbol document sid)
p (get (pal/palettes document) (:palette-ref sym))]
@ -423,7 +404,12 @@
(let [named? #(hit? query (clip/symbol-name document %))
top (when (and main (named? main)) main)
symbol-ids (sort-by str (keys (:symbols document)))
transition? #(= :palette (:type (clip/symbol document %)))
transition-ids (into #{} (mapcat (fn [sym]
(when (= :palette-track (:type sym))
(keep (comp :symbol :source val) (:nodes sym)))))
(vals (:symbols document)))
transition? #(or (= :palette (:type (clip/symbol document %)))
(contains? transition-ids %))
transitions (filterv #(and (named? %) (transition? %)) symbol-ids)
rest (filterv #(and (named? %) (not= main %)
(not (#{:palette :palette-track}
@ -431,11 +417,10 @@
symbol-ids)
media (filterv #(hit? query (:label %)) media)
sounds (filterv #(hit? query (:label %)) sounds)
palettes (filterv #(hit? query (:name (val %)))
(sort-by (comp str :name val) (pal/palettes document)))]
]
[sections searching?
(+ (if top 1 0) (count rest) (count transitions)
(count media) (count sounds) (count palettes))
(count media) (count sounds))
[{:title "project" :searching? searching?
:blank "nothing to open yet"
:rows (when top [(symbol-row document top ctx)])}
@ -445,11 +430,6 @@
{:title "palette transitions" :searching? searching?
:blank "no palette transitions"
:rows (mapv #(palette-transition-row document % selection rename) transitions)}
{:title "palettes" :searching? searching?
:blank "no palettes"
:rows (mapv (fn [[id p]] (palette-row id p (:default-palette document)
(or palette-choice (pal/default-palette-id document))
rename)) palettes)}
{:title "media" :searching? searching?
:blank "drop a video here"
:rows (mapv #(footage-row % chosen rename) media)}

View file

@ -887,30 +887,25 @@
;; one, else this row's own instance. It opens as a tab, which is what
;; double-clicking the same symbol in the pool does.
:on-double-click (fn [^js e]
(when-let [source (and (not= :palette kind)
(or (:source (clip-under e)) of))]
(.stopPropagation e)
(rf/dispatch [::pb/open-symbol source])))
(let [under (clip-under e)]
(cond
(and lane? (nil? under))
(do (.stopPropagation e)
(rf/dispatch [::ui/new-symbol-at
(frame-at e frames) select]))
:else
(when-let [source (or (:source under) of)]
(.stopPropagation e)
(rf/dispatch [::pb/open-symbol source])))))
:ref (when lane? (fn [el] (when el (aset el "arthurLane" select))))
:on-drag-enter (fn [^js e]
;; A palette hover belongs only to the palette row. If
;; the pointer leaves it for an ordinary row, clear its
;; last accepted preview even though this row correctly
;; declines the native drop.
(when (and (drag/palette?) (not= :palette kind))
(rf/dispatch [::ui/drop-clear]))
(cond
(and (= :palette kind) (drag/palette?))
(do (.preventDefault e) (.stopPropagation e))
(and (not= :palette kind) lane?
(or (drag/accepts?) (drag/row)))
(do (.preventDefault e) (.stopPropagation e))))
:on-drag-over (fn [^js e]
(cond
(and (= :palette kind) (drag/palette?))
(do (.preventDefault e) (.stopPropagation e)
(set! (.. e -dataTransfer -dropEffect) "copy")
(drag/hover! :timeline (frame-at e frames) nil select))
(and (not= :palette kind) lane?
(or (drag/accepts?) (drag/row)))
(do (.preventDefault e) (.stopPropagation e)
@ -920,10 +915,6 @@
(drag/hover! :timeline (frame-at e frames) nil select)))))
:on-drop (fn [^js e]
(cond
(and (= :palette kind) (drag/palette?))
(let [at (frame-at e frames)]
(.preventDefault e) (.stopPropagation e)
(drag/land-palette! open at))
(and (not= :palette kind) lane?
(or (drag/accepts?) (drag/row)))
(do (.preventDefault e)

View file

@ -4,7 +4,8 @@
in the renderer reads. These assert the parts of that claim that could silently
stop being true."
(:require [cljs.test :refer [deftest is testing]]
[arthur.domain.channel :as ch]))
[arthur.domain.channel :as ch]
[arthur.domain.palette :as pal]))
;; ---- the three shapes read the same way ----
@ -392,6 +393,21 @@
(is (= {:from :day :to :night :t 0.5}
(ch/value-at blend 5 nil)))))
(deftest palette-choice-channels-blend-editor-uuid-identities
(let [day (random-uuid)
night (random-uuid)
blend (assoc (ch/keyed {0 day 10 night} :linear) :semantic :palette)]
(is (empty? (ch/problems blend)))
(is (= {:from day :to night :t 0.5}
(ch/value-at blend 5 nil)))))
(deftest palette-choice-channels-can-blend-from-inherit
(let [night (random-uuid)
blend (assoc (ch/keyed {0 pal/inherit 10 night} :linear) :semantic :palette)]
(is (empty? (ch/problems blend)))
(is (= {:from pal/inherit :to night :t 0.5}
(ch/value-at blend 5 nil)))))
(deftest numeric-channels-can-ramp-between-keys
(let [c (ch/keyed {0 0.0, 10 1.0} :linear)
cursor (ch/cursor c nil)]

View file

@ -406,3 +406,32 @@
(is (nil? (:refused extended)) (:refused extended))
(is (= [0 6] (node/placed-span
(get-in extended [:clip :symbols :palettes :nodes :change]))))))
(deftest a-blank-palette-symbol-can-tween-from-inherit-to-an-editor-palette
(let [day (random-uuid)
night (random-uuid)
palette (fn [id color]
{:id id :name (str id) :slots [{:hex color} {:hex color}]})
choice (assoc (ch/keyed {0 pal/inherit 4 night} :linear) :semantic :palette)
document {:fps 30 :width 20 :height 20
:palettes {day (palette day "#000000")
night (palette night "#ffffff")}
:default-palette day
:symbols
{:main {:id :main :frames 5 :palette day :palette-track :palettes
:nodes {}}
:palettes {:id :palettes :type :palette-track :display :lane :frames 5
:nodes {:change {:id :change :kind :instance :z "a1"
:source {:symbol :transition}
:span [0 5] :time {:at 0}
:channels {[:palette] choice}}}}
:transition {:id :transition :name "palette transition"
:type :palette :frames 1 :nodes {}}}}
context (pal/compile document)
resolve (clip/resolver document :main nil context nil)]
(is (empty? (clip/problems document)))
(resolve 2)
(is (= {:from day :to night :t 0.5} (clip/active-palette resolve)))
(is (= [128 128 128]
(nth (pal/effective-ramp context (clip/active-palette resolve))
(pal/render-index context day 1))))))

View file

@ -5,6 +5,7 @@
[arthur.domain.history :as history]
[arthur.domain.leaf :as leaf]
[arthur.domain.node :as node]
[arthur.domain.palette :as pal]
[arthur.domain.sequence-test :as fixture]
[arthur.domain.span :as span]
[arthur.events.ui :as ui]
@ -71,6 +72,40 @@
(vals (get-in saved [:symbols :main :nodes]))))
"claiming the frame leaves no overlapping cel"))))
(deftest double-click-creation-uses-the-lane-and-pointer-frame
(let [doc (fixture/document)
id (store/install! {:clip doc :store {}} "double-click-new-symbol")]
(reset! rf-db/app-db {:clip/current id :paint/revision 0
:ui {:open :main} :playback {:frame 0}})
(rf/dispatch-sync [::ui/new-symbol-at 5 [:node :main nil []]])
(let [saved (:clip (store/entry id))
[_ sid instance-id] (get-in @rf-db/app-db [:ui :selection])
instance (get-in saved [:symbols sid :nodes instance-id])]
(is (= :main sid))
(is (= [5 6] (node/placed-span instance)))
(is (= 1 (clip/frames saved (node/source instance))))
(is (zero? (get-in @rf-db/app-db [:playback :frame]))
"the pointer frame, not the playhead, chooses the new cel's time"))))
(deftest the-same-double-click-command-creates-a-palette-symbol-on-the-palette-row
(let [doc (clip/blank)
id (store/install! {:clip doc :store {}} "double-click-palette-symbol")]
(reset! rf-db/app-db {:clip/current id :paint/revision 0
:ui {:open :main} :playback {:frame 0}})
(rf/dispatch-sync [::ui/new-symbol-at 5
[:arthur.ui.timeline/palette-track :main]])
(let [saved (:clip (store/entry id))
track-id (get-in saved [:symbols :main :palette-track])
[_ sid instance-id] (get-in @rf-db/app-db [:ui :selection])
instance (get-in saved [:symbols sid :nodes instance-id])
source (node/source instance)]
(is (= track-id sid))
(is (= :palette-track (get-in saved [:symbols track-id :type])))
(is (= :palette (get-in saved [:symbols source :type])))
(is (= [5 6] (node/placed-span instance)))
(is (= pal/inherit
(get-in instance [:channels [:palette] :value]))))))
(deftest a-new-lane-uses-the-symbol-selected-at-the-playhead
(let [doc (clip/blank)
id (store/install! {:clip doc :store {}} "nested-new-lane")]