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

Speed up the frame, and drop loop/recur from the domain

Browse source 
The frame went 5.86ms to 3.17ms -- a 170fps ceiling to 315 -- and `loop`/`recur`
is gone from src/ entirely.

Two real wins, both from measuring rather than guessing:

- `->rgba` was 3.16ms of that frame and was scene-independent: a `nth` into a
  vector of vectors is four protocol dispatches per pixel, 64,000 pixels a frame.
  The palette is now flattened once and cached by identity of the source vector
  -- palettes are values, so identity is exactly the right test and there is no
  invalidation to get wrong. At zoom 1 on a little-endian machine the inner loop
  is one 32-bit write per pixel through a Uint32Array view of the same buffer:
  0.11ms, 28x. Every other case walks bytes off the same flat palette.
  raster-test pins both against a naive per-pixel reference at three zooms,
  because a fast path that is subtly wrong about colour would look like a palette
  bug rather than like an optimisation.

- The per-frame z sort was re-deriving a constant. Draw order is a function of
  the z paths, which change when the scene changes and never because the playhead
  moved, so `draw-rank` computes it once and a frame sorts small integers. Every
  op drops its `:i` and `:z-path` fields as a result.

The loop pass, and an honest note on it: it came out NET POSITIVE on lines, which
is the wrong direction for a cleanup. geom is -3 (transduce for the accumulators,
`(-> (iterate refine ref) (nth iters))` for Procrustes, which is what the
algorithm says rather than a counter that happens to stop), channel -3,
fill-poly!'s copy loop 7 lines to 1. Against that, eval-into went from one
four-deep pyramid with seven positional parameters to `place` / `emit` / a fold
over a ctx map -- less nesting, more lines, and a different change from "fix the
loops" that should not have been bundled with it.

Two idioms were reverted for being worse here than what they replaced, both the
same mistake -- reaching for a form that allocates inside a hot loop:

- `partition 2` over an `array-seq` per scanline is some five thousand throwaway
  objects a frame and took draw from 0.88ms to 1.48ms. Now a pairwise `dotimes`
  over the array.
- `z-lex` via `(map compare a b)` allocated three lazy seqs per call, ~700 calls
  a frame. Made moot by `draw-rank`.

And one DRY move reverted for coupling things that only coincide: a `geom-path`
table had `node/valid-paths` and `scene/emit` deriving from one source, which
ties what a kind may CARRY to what the renderer READS off it. Those are the same
today and are not the same question, and the table put a spec change in charge of
what gets drawn, across a namespace boundary. `emit`'s three branches are three
different marks and stay three branches.

Kept, because it is one operation with two callers rather than two concerns that
rhyme: `lineage`, which `depth` and `z-path` were both walking separately. Its
cycle check is now a length bound -- a chain that does not repeat cannot be
longer than the node count -- instead of a `seen` set.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01PDfHGdV39zu6rvgbBTfDaT
This commit is contained in:
Olive Vaughn 2026-09-27 17:44:07 -04:00
parent 18d6495592
commit 11192d61c6
7 changed files with 396 additions and 288 deletions
Download patch file Download diff file Expand all files Collapse all files

5
frontend/src/arthur/domain/channel.cljs
View file

@ -29,8 +29,7 @@
it exists so the UI can offer a parameter panel instead of raw keys. It lives it exists so the UI can offer a parameter panel instead of raw keys. It lives
on the channel rather than the node because a mouth wants a rotoscoped on the channel rather than the node because a mouth wants a rotoscoped
[:geom :pts] and a hand-animated [:xform :pos] at the same time, and putting [:geom :pts] and a hand-animated [:xform :pos] at the same time, and putting
the flag on the node would forbid the most useful thing in the model." the flag on the node would forbid the most useful thing in the model.")
(:require [clojure.string :as str]))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; the state mask ;; the state mask
@ -284,5 +283,3 @@
(and (map? ch) (seq (:over ch))) (and (map? ch) (seq (:over ch)))
(conj ":over layers are not implemented (port-plan step 2 scope)"))) (conj ":over layers are not implemented (port-plan step 2 scope)")))
(defn problems-str [ch]
(str/join "; " (problems ch)))

86
frontend/src/arthur/domain/geom.cljs
View file

@ -6,6 +6,13 @@
port is worth more here than a fast one. The dense typed-array port is worth more here than a fast one. The dense typed-array
representations appear at the freeze boundary, not below it.") representations appear at the freeze boundary, not below it.")
(defn centroid
"Mean of a point set."
[pts]
(let [n (count pts)]
{:x (/ (transduce (map :x) + 0.0 pts) n)
:y (/ (transduce (map :y) + 0.0 pts) n)}))
(defn fit-similarity (defn fit-similarity
"Least-squares similarity (translation + rotation + uniform scale, 4 DOF) "Least-squares similarity (translation + rotation + uniform scale, 4 DOF)
mapping P onto Q. Closed form; no iteration. mapping P onto Q. Closed form; no iteration.
@ -15,24 +22,24 @@
Four DOF removes exactly translation, roll and depth-scale, and leaves yaw and Four DOF removes exactly translation, roll and depth-scale, and leaves yaw and
pitch as a measurable residual." pitch as a measurable residual."
[P Q] [P Q]
(let [n (count P) (let [n (count P)
[pcx pcy qcx qcy] cp (centroid P)
(loop [i 0, pcx 0.0, pcy 0.0, qcx 0.0, qcy 0.0] cq (centroid Q)
(if (< i n) ;; Dot, cross and squared norm of the centred configurations, in one
(recur (inc i) ;; pass. Reduced in input order, so the floating-point result is bit for
(+ pcx (:x (nth P i))) (+ pcy (:y (nth P i))) ;; bit what an index loop would give and the 1e-9 parity against the JS
(+ qcx (:x (nth Q i))) (+ qcy (:y (nth Q i)))) ;; holds.
[(/ pcx n) (/ pcy n) (/ qcx n) (/ qcy n)]))
[a b norm] [a b norm]
(loop [i 0, a 0.0, b 0.0, norm 0.0] (reduce (fn [[a b norm] [p q]]
(if (< i n) (let [px (- (:x p) (:x cp)) py (- (:y p) (:y cp))
(let [px (- (:x (nth P i)) pcx) py (- (:y (nth P i)) pcy) qx (- (:x q) (:x cq)) qy (- (:y q) (:y cq))]
qx (- (:x (nth Q i)) qcx) qy (- (:y (nth Q i)) qcy)] [(+ a (+ (* px qx) (* py qy))) ; dot
(recur (inc i)
(+ a (+ (* px qx) (* py qy))) ; dot
(+ b (- (* px qy) (* py qx))) ; cross (+ b (- (* px qy) (* py qx))) ; cross
(+ norm (+ (* px px) (* py py))))) (+ norm (+ (* px px) (* py py)))]))
[a b norm])) [0.0 0.0 0.0]
(map vector P Q))
pcx (:x cp) pcy (:y cp)
qcx (:x cq) qcy (:y cq)
theta (js/Math.atan2 b a) theta (js/Math.atan2 b a)
;; A degenerate configuration has nothing to recover a scale from. Fall ;; A degenerate configuration has nothing to recover a scale from. Fall
;; back to 1 rather than dividing by zero: one bad detection frame would ;; back to 1 rather than dividing by zero: one bad detection frame would
@ -58,17 +65,14 @@
"Residual RMS after the fit, in the units of Q. Rises with out-of-plane "Residual RMS after the fit, in the units of Q. Rises with out-of-plane
rotation, so it is the signal for \"this section is not stabilisable\"." rotation, so it is the signal for \"this section is not stabilisable\"."
[tf P Q] [tf P Q]
(let [n (count P)] (let [sq (fn [d] (* d d))]
(js/Math.sqrt (js/Math.sqrt
(/ (loop [i 0, acc 0.0] (/ (transduce (map (fn [[p q]]
(if (< i n) (let [m (apply-sim tf p)]
(let [m (apply-sim tf (nth P i)) (+ (sq (- (:x m) (:x q)))
q (nth Q i)] (sq (- (:y m) (:y q)))))))
(recur (inc i) + 0.0 (map vector P Q))
(+ acc (js/Math.pow (- (:x m) (:x q)) 2) (count P)))))
(js/Math.pow (- (:y m) (:y q)) 2))))
acc))
n))))
(defn procrustes-mean (defn procrustes-mean
"Generalised Procrustes: the reference is the MEAN rigid configuration over the "Generalised Procrustes: the reference is the MEAN rigid configuration over the
@ -76,20 +80,22 @@
other frame. Three passes is plenty." other frame. Three passes is plenty."
([frames-rigid] (procrustes-mean frames-rigid 3)) ([frames-rigid] (procrustes-mean frames-rigid 3))
([frames-rigid iters] ([frames-rigid iters]
(let [n (count frames-rigid)] (let [n (count frames-rigid)
(loop [ref (mapv (fn [p] {:x (:x p) :y (:y p)}) (nth frames-rigid 0)) ;; One pass: fit every frame onto the current reference, sum the
iter 0] ;; aligned configurations, divide. Iterative refinement, so the whole
(if (= iter iters) ;; thing is `iterate` taken `iters` deep — which is what the algorithm
ref ;; actually says, rather than a counter that happens to stop.
(recur refine (fn [ref]
(->> frames-rigid (->> frames-rigid
(reduce (fn [acc rig] (reduce (fn [acc rig]
(let [moved (apply-sim-all (fit-similarity rig ref) rig)] (let [moved (apply-sim-all (fit-similarity rig ref) rig)]
(mapv (fn [a m] {:x (+ (:x a) (:x m)) :y (+ (:y a) (:y m))}) (mapv (fn [a m] {:x (+ (:x a) (:x m))
acc moved))) :y (+ (:y a) (:y m))})
(mapv (constantly {:x 0.0 :y 0.0}) ref)) acc moved)))
(mapv (fn [p] {:x (/ (:x p) n) :y (/ (:y p) n)}))) (mapv (constantly {:x 0.0 :y 0.0}) ref))
(inc iter))))))) (mapv (fn [p] {:x (/ (:x p) n) :y (/ (:y p) n)}))))]
(-> (iterate refine (mapv (fn [p] {:x (:x p) :y (:y p)}) (first frames-rigid)))
(nth iters)))))
(defn moving-average (defn moving-average
"`radius` is in frames either side: 0 is off, 1 averages over 3 frames, 2 over "`radius` is in frames either side: 0 is off, 1 averages over 3 frames, 2 over

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

@ -15,8 +15,7 @@
interpolating matrix entries is meaningless: a rotation tweened through its interpolating matrix entries is meaningless: a rotation tweened through its
matrix shears on the way. Flat Float64Array for evaluation because at 30fps matrix shears on the way. Flat Float64Array for evaluation because at 30fps
per-frame allocation is the only thing that will make this stutter." per-frame allocation is the only thing that will make this stutter."
(:require [arthur.domain.channel :as ch] (:require [arthur.domain.channel :as ch]))
[clojure.string :as str]))
(def kinds (def kinds
"`:symbol` and `:bitmap` are in the vocabulary and not implemented; they are "`:symbol` and `:bitmap` are in the vocabulary and not implemented; they are
@ -38,14 +37,19 @@
(def valid-paths (def valid-paths
"The set of valid channel paths follows from the node's :kind, and that is a "The set of valid channel paths follows from the node's :kind, and that is a
SPEC rather than a schema migration — a node does not grow or lose fields, it SPEC rather than a schema migration — a node does not grow or lose fields, it
simply has no `[:geom :radius]` unless it is a disc." simply has no `[:geom :radius]` unless it is a disc.
Written out per kind rather than derived from a table shared with the
renderer. What a kind may CARRY and what the renderer READS off it coincide
today and are not the same question, and tying them together would make a
change to this spec silently change what gets drawn."
(let [base (into #{[:vis]} xform-paths)] (let [base (into #{[:vis]} xform-paths)]
{:group base {:group base
:poly (into base [[:geom :pts] [:style :color]]) :poly (into base [[:geom :pts] [:style :color]])
;; A disc's radius is framed in practice (iris size is a knob, not a ;; A disc's radius is framed in practice — iris size is a knob, not a
;; performance) but it is a channel like any other so that it can be keyed. ;; performance — but it is a channel like any other so it can be keyed.
:disc (into base [[:geom :radius] [:style :color]]) :disc (into base [[:geom :radius] [:style :color]])
;; :size, not a radius: the pupil is a SQUARE, and an exactly size x size ;; :size, not a radius: the pupil is a SQUARE, an exactly size x size
;; block. See raster/fill-rect!. ;; block. See raster/fill-rect!.
:rect (into base [[:geom :size] [:style :color]])})) :rect (into base [[:geom :size] [:style :color]])}))
@ -253,5 +257,3 @@
p (ch/problems c)] p (ch/problems c)]
(str "channel " (pr-str path) ": " p)))))) (str "channel " (pr-str path) ": " p))))))
(defn problems-str [n]
(str/join "; " (problems n)))

202
frontend/src/arthur/domain/raster.cljs
View file

@ -38,43 +38,47 @@
into a plain JS array and sorted in place." into a plain JS array and sorted in place."
[{:keys [w h buf] :as r} pts n index] [{:keys [w h buf] :as r} pts n index]
(when (>= n 3) (when (>= n 3)
(let [px (fn [i] (if (vector? pts) (-nth pts (* 2 i)) (aget pts (* 2 i)))) (let [px (fn [i] (if (vector? pts) (-nth pts (* 2 i)) (aget pts (* 2 i))))
py (fn [i] (if (vector? pts) (-nth pts (inc (* 2 i))) (aget pts (inc (* 2 i))))) py (fn [i] (if (vector? pts) (-nth pts (inc (* 2 i))) (aget pts (inc (* 2 i)))))
xs (array)] xs (array)
(let [ymin (loop [i 1, acc (py 0)] (if (< i n) (recur (inc i) (min acc (py i))) acc)) ys (map py (range n))
ymax (loop [i 1, acc (py 0)] (if (< i n) (recur (inc i) (max acc (py i))) acc)) y0 (max 0 (js/Math.ceil (- (reduce min ys) 0.5)))
y0 (max 0 (js/Math.ceil (- ymin 0.5))) y1 (min (dec h) (inc (js/Math.floor (- (reduce max ys) 0.5))))]
y1 (min (dec h) (inc (js/Math.floor (- ymax 0.5))))] ;; `dotimes` over the span rather than a hand-rolled index: bounded
(loop [y y0] ;; iteration with no accumulator is what it is for, and it compiles to the
(when (<= y y1) ;; same JS for-loop the recur did.
(let [sy (+ y 0.5)] (dotimes [dy (inc (- y1 y0))]
(set! (.-length xs) 0) (let [y (+ y0 dy)
(dotimes [i n] sy (+ y 0.5)]
(let [j (mod (inc i) n) (set! (.-length xs) 0)
ay (py i) by (py j)] (dotimes [i n]
;; A horizontal edge contributes no crossing, and dividing by (let [j (mod (inc i) n)
;; its zero height would emit Infinity. ay (py i) by (py j)]
(when (not= ay by) ;; A horizontal edge contributes no crossing, and dividing by its
(let [lo (min ay by) hi (max ay by)] ;; zero height would emit Infinity.
;; Half-open in y: >= lo and < hi. A vertex shared by two (when (not= ay by)
;; edges is counted exactly once, so the parity cannot flip (let [lo (min ay by) hi (max ay by)]
;; at a corner and leak a whole scanline. ;; Half-open in y: >= lo and < hi. A vertex shared by two edges
(when (and (>= sy lo) (< sy hi)) ;; is counted exactly once, so the parity cannot flip at a
(.push xs (+ (px i) (* (/ (- sy ay) (- by ay)) ;; corner and leak a whole scanline.
(- (px j) (px i)))))))))) (when (and (>= sy lo) (< sy hi))
(when (>= (.-length xs) 2) (.push xs (+ (px i) (* (/ (- sy ay) (- by ay))
(.sort xs (fn [a b] (- a b))) (- (px j) (px i))))))))))
(loop [k 0] (when (>= (.-length xs) 2)
(when (< (inc k) (.-length xs)) (.sort xs (fn [a b] (- a b)))
(let [x-from (max 0 (js/Math.ceil (- (aget xs k) 0.5))) ;; Crossings pair up left to right: inside a span, outside the next.
x-to (min (dec w) (js/Math.floor (- (aget xs (inc k)) 0.5))) ;; Iterated as PAIRS rather than as a stepped index, but over the
row (* y w)] ;; array directly — `partition 2` over an `array-seq` says the same
(loop [x x-from] ;; thing and allocates two seqs per scanline, which is some five
(when (<= x x-to) ;; thousand throwaway objects a frame in the hottest loop here.
(aset buf (+ row x) index) (dotimes [k (quot (.-length xs) 2)]
(recur (inc x))))) (let [xa (aget xs (* 2 k))
(recur (+ k 2)))))) xb (aget xs (inc (* 2 k)))
(recur (inc y))))))) x-from (max 0 (js/Math.ceil (- xa 0.5)))
x-to (min (dec w) (js/Math.floor (- xb 0.5)))
row (* y w)]
(dotimes [dx (inc (- x-to x-from))]
(aset buf (+ row x-from dx) index)))))))))
r) r)
(defn fill-poly! (defn fill-poly!
@ -85,14 +89,7 @@
scanline implementation serves both, because two would drift and the drift scanline implementation serves both, because two would drift and the drift
would read as a rendering bug rather than as two functions disagreeing." would read as a rendering bug rather than as two functions disagreeing."
[r pts index] [r pts index]
(let [n (count pts) (fill-poly-buf! r (into-array (mapcat (juxt :x :y) pts)) (count pts) index))
a (js/Float64Array. (* 2 n))]
(loop [i 0, ps (seq pts)]
(when ps
(aset a (* 2 i) (:x (first ps)))
(aset a (inc (* 2 i)) (:y (first ps)))
(recur (inc i) (next ps))))
(fill-poly-buf! r a n index)))
(defn fill-disc! (defn fill-disc!
"`over` is an optional stencil: when given, only pixels that currently hold "`over` is an optional stencil: when given, only pixels that currently hold
@ -109,18 +106,16 @@
y1 (min (dec h) (js/Math.ceil (+ cy rad))) y1 (min (dec h) (js/Math.ceil (+ cy rad)))
x0 (max 0 (js/Math.floor (- cx rad))) x0 (max 0 (js/Math.floor (- cx rad)))
x1 (min (dec w) (js/Math.ceil (+ cx rad)))] x1 (min (dec w) (js/Math.ceil (+ cx rad)))]
(loop [y y0] (dotimes [iy (inc (- y1 y0))]
(when (<= y y1) (dotimes [ix (inc (- x1 x0))]
(loop [x x0] (let [x (+ x0 ix)
(when (<= x x1) y (+ y0 iy)
(let [dx (- (+ x 0.5) cx) dx (- (+ x 0.5) cx)
dy (- (+ y 0.5) cy)] dy (- (+ y 0.5) cy)]
(when (<= (+ (* dx dx) (* dy dy)) rr) (when (<= (+ (* dx dx) (* dy dy)) rr)
(let [o (+ (* y w) x)] (let [o (+ (* y w) x)]
(when (or (nil? over) (= (aget buf o) over)) (when (or (nil? over) (= (aget buf o) over))
(aset buf o index))))) (aset buf o index)))))))
(recur (inc x))))
(recur (inc y))))
r))) r)))
(defn fill-rect! (defn fill-rect!
@ -142,50 +137,89 @@
(when (>= size 1) (when (>= size 1)
(let [x0 (js/Math.round (- cx (/ size 2))) (let [x0 (js/Math.round (- cx (/ size 2)))
y0 (js/Math.round (- cy (/ size 2)))] y0 (js/Math.round (- cy (/ size 2)))]
(loop [y (max 0 y0)] (let [ya (max 0 y0) yb (min h (+ y0 size))
(when (< y (min h (+ y0 size))) xa (max 0 x0) xb (min w (+ x0 size))]
(loop [x (max 0 x0)] (dotimes [iy (- yb ya)]
(when (< x (min w (+ x0 size))) (dotimes [ix (- xb xa)]
(let [o (+ (* y w) x)] (let [o (+ (* (+ ya iy) w) xa ix)]
(when (or (nil? over) (= (aget buf o) over)) (when (or (nil? over) (= (aget buf o) over))
(aset buf o index))) (aset buf o index))))))))
(recur (inc x))))
(recur (inc y))))))
r)) r))
(def ^:private little-endian?
(let [b (js/ArrayBuffer. 4)]
(aset (js/Uint32Array. b) 0 1)
(= 1 (aget (js/Uint8Array. b) 0))))
;; The palette arrives as a CLJS vector of [r g b] vectors, which is the right
;; shape to author and the wrong shape to read 64,000 times a frame: a `nth` into
;; a vector of vectors is four protocol dispatches per pixel, and that measured at
;; 3.16ms per frame against 0.11ms for the same work off typed arrays. So it is
;; flattened once and cached by IDENTITY of the source vector — palettes are
;; values and a swap replaces the whole thing, so identity is exactly the right
;; test and there is no invalidation to get wrong.
(defonce ^:private flat-cache (atom nil))
(defn- flatten-palette [palette-rgb]
(let [cached @flat-cache]
(if (and cached (identical? palette-rgb (:src cached)))
cached
(let [p8 (js/Uint8Array. (* 256 3))
p32 (js/Uint32Array. 256)]
(dotimes [i 256]
;; An index with no palette entry comes out MAGENTA rather than
;; transparent or black: writing an index the palette does not have is
;; a bug, and it should be impossible to miss.
(let [c (or (nth palette-rgb i nil) [255 0 255])
r (nth c 0) g (nth c 1) b (nth c 2)]
(aset p8 (* i 3) r)
(aset p8 (+ 1 (* i 3)) g)
(aset p8 (+ 2 (* i 3)) b)
(aset p32 i (if little-endian?
(bit-or (bit-shift-left 255 24) (bit-shift-left b 16)
(bit-shift-left g 8) r)
(bit-or (bit-shift-left r 24) (bit-shift-left g 16)
(bit-shift-left b 8) 255)))))
(reset! flat-cache {:src palette-rgb :p8 p8 :p32 p32})))))
(defn ->rgba (defn ->rgba
"Expand indices through the palette at integer zoom. Nearest-neighbour by "Expand indices through the palette at integer zoom. Nearest-neighbour by
construction, so no filtering softens the result. construction, so no filtering softens the result.
Returns {:width :height :data} with :data a Uint8ClampedArray, ready to hand to Returns {:width :height :data} with :data a Uint8ClampedArray, ready to hand to
an ImageData. An index with no palette entry comes out magenta rather than an ImageData.
transparent or black: writing an index the palette does not have is a bug, and
it should be impossible to miss.
`dest` is an optional Uint8ClampedArray to write into instead of allocating `dest` is an optional Uint8ClampedArray to write into instead of allocating
one. At 320x200 the buffer is 256KB, and allocating and discarding that thirty one. At 320x200 the buffer is 256KB, and allocating and discarding that thirty
times a second is exactly the per-frame allocation the model is arranged to times a second is exactly the per-frame allocation the model is arranged to
avoid; ui/canvas passes the live ImageData's own array." avoid; ui/canvas passes the live ImageData's own array.
At zoom 1 on a little-endian machine this writes ONE 32-bit word per pixel
through a Uint32Array view of the same buffer, which is the whole of the inner
loop. Every other case walks bytes. Both paths read the same flattened palette
and raster-test asserts they agree with a naive reference pixel for pixel,
because a fast path that is subtly wrong about colour would look like a palette
bug rather than like an optimisation."
([r palette-rgb] (->rgba r palette-rgb 1 nil)) ([r palette-rgb] (->rgba r palette-rgb 1 nil))
([r palette-rgb zoom] (->rgba r palette-rgb zoom nil)) ([r palette-rgb zoom] (->rgba r palette-rgb zoom nil))
([{:keys [w h buf]} palette-rgb zoom dest] ([{:keys [w h buf]} palette-rgb zoom dest]
(let [W (* w zoom) (let [W (* w zoom)
H (* h zoom) H (* h zoom)
d (or dest (js/Uint8ClampedArray. (* W H 4)))] d (or dest (js/Uint8ClampedArray. (* W H 4)))
(loop [y 0] {:keys [p8 p32]} (flatten-palette palette-rgb)]
(when (< y H) (if (and (= 1 zoom) little-endian? (zero? (mod (.-byteOffset d) 4)))
(let [v (js/Uint32Array. (.-buffer d) (.-byteOffset d) (* w h))]
(dotimes [i (* w h)]
(aset v i (aget p32 (aget buf i)))))
(dotimes [y H]
(let [srow (* (js/Math.floor (/ y zoom)) w)] (let [srow (* (js/Math.floor (/ y zoom)) w)]
(loop [x 0] (dotimes [x W]
(when (< x W) (let [p (* 3 (aget buf (+ srow (js/Math.floor (/ x zoom)))))
(let [c (or (nth palette-rgb (aget buf (+ srow (js/Math.floor (/ x zoom)))) nil) o (* (+ (* y W) x) 4)]
[255 0 255]) (aset d o (aget p8 p))
o (* (+ (* y W) x) 4)] (aset d (+ o 1) (aget p8 (+ p 1)))
(aset d o (nth c 0)) (aset d (+ o 2) (aget p8 (+ p 2)))
(aset d (+ o 1) (nth c 1)) (aset d (+ o 3) 255))))))
(aset d (+ o 2) (nth c 2))
(aset d (+ o 3) 255))
(recur (inc x)))))
(recur (inc y))))
{:width W :height H :data d}))) {:width W :height H :data d})))
(defn draw-ops! (defn draw-ops!

341
frontend/src/arthur/domain/scene.cljs
View file

@ -29,26 +29,38 @@
fill in the same channel rather than convert into a second format." fill in the same channel rather than convert into a second format."
(:require [arthur.domain.channel :as ch] (:require [arthur.domain.channel :as ch]
[arthur.domain.node :as node] [arthur.domain.node :as node]
[arthur.domain.palette :as pal] [arthur.domain.palette :as pal]))
[clojure.string :as str]))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; structure: depth, topological order, draw order ;; structure: depth, topological order, draw order
(defn depth (defn lineage
"Number of ancestors. Throws on a parent cycle rather than looping forever — a "The node's id and every ancestor's, nearest first and root last.
cycle is reachable from one bad `:node/set-parent`, and a hung tab is a much
worse diagnostic than a stack trace naming the two nodes." One walk, shared by `depth` and `z-path`, which otherwise duplicate it.
A cycle is caught by LENGTH rather than by a `seen` set: a chain that does not
repeat cannot be longer than the number of nodes, so one step past that is
proof of a loop and needs no bookkeeping. Caught rather than hung — a cycle is
reachable from one bad `:node/set-parent`, and a hung tab is a far worse
diagnostic than a stack trace naming the nodes."
[nodes id] [nodes id]
(loop [id id, d 0, seen #{}] (let [up (fn [i]
(let [p (:parent (get nodes id))] (when-let [p (:parent (get nodes i))]
(cond (if (contains? nodes p)
(nil? p) d p
(contains? seen p) (throw (ex-info "node's :parent is not in the scene"
(throw (ex-info "parent cycle in scene" {:node id :cycle (conj seen p)})) {:node i :parent p})))))
(nil? (get nodes p)) chain (into [] (comp (take-while some?) (take (inc (count nodes))))
(throw (ex-info "node's :parent is not in the scene" {:node id :parent p})) (iterate up id))]
:else (recur p (inc d) (conj seen p)))))) (when (> (count chain) (count nodes))
(throw (ex-info "parent cycle in scene" {:node id :chain chain})))
chain))
(defn depth
"Number of ancestors."
[nodes id]
(dec (count (lineage nodes id))))
(defn order (defn order
"Node ids in topological order: every node after its parent. "Node ids in topological order: every node after its parent.
@ -58,7 +70,7 @@
parent's. Ties are broken by id so the order is deterministic across runs, parent's. Ties are broken by id so the order is deterministic across runs,
which matters because the draw-order sort below falls back on this position." which matters because the draw-order sort below falls back on this position."
[nodes] [nodes]
(vec (sort-by (juxt #(depth nodes %) #(str %)) (keys nodes)))) (vec (sort-by (juxt #(depth nodes %) str) (keys nodes))))
(defn z-path (defn z-path
"The node's z index and every ancestor's, root first. "The node's z index and every ancestor's, root first.
@ -71,29 +83,34 @@
lexicographically, so a node can always be inserted between two siblings lexicographically, so a node can always be inserted between two siblings
without renumbering either." without renumbering either."
[nodes id] [nodes id]
(loop [id id, acc ()] (mapv #(:z (get nodes %)) (rseq (lineage nodes id))))
(if (nil? id)
(vec acc)
(let [n (get nodes id)]
(recur (:parent n) (conj acc (:z n)))))))
(defn- z-lex (defn- z-lex
"Lexicographic compare of two z paths, a prefix sorting first. "Lexicographic compare of two z paths, a prefix sorting first.
`compare` on vectors will not do: it compares COUNT first, so a deep `compare` on vectors will not do: it compares COUNT first, so a deep
descendant of \"a1\" would sort after a shallow \"a2\" and a painted cel would descendant of \"a1\" would sort after a shallow \"a2\" and a painted cel would
jump in front of the head that carries it." jump in front of the head that carries it.
[a b]
(let [na (count a), nb (count b)]
(loop [i 0]
(if (or (= i na) (= i nb))
(- na nb)
(let [c (compare (nth a i) (nth b i))]
(if (zero? c) (recur (inc i)) c))))))
(defn- op-compare [x y] `map` over two collections stops at the shorter and `first` short-circuits at
(let [c (z-lex (:z-path x) (:z-path y))] the first difference, so this walks no further than it has to."
(if (zero? c) (- (:i x) (:i y)) c))) [a b]
(or (first (remove zero? (map compare a b)))
(- (count a) (count b))))
(defn draw-rank
"id -> its position in draw order.
Computed ONCE. Draw order is a function of the z paths, which are structural —
they change when the scene changes and never because the playhead moved — so
sorting ops by z on every frame was re-deriving a constant thirty times a
second. Here it is derived when the scene is, and a frame sorts small integers.
`sort-by` is stable and `ord` is topological, so nodes sharing a z path keep
parent-before-child order without a tiebreak field on every op."
[nodes ord]
(let [paths (into {} (map (juxt identity #(z-path nodes %))) ord)]
(into {} (map-indexed (fn [i id] [id i])) (sort-by paths z-lex ord))))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; colour ;; colour
@ -144,7 +161,7 @@
A node stencilled by something that drew NOTHING is DROPPED, not drawn A node stencilled by something that drew NOTHING is DROPPED, not drawn
unclipped: unclipped would be an iris floating over the cheek on exactly the unclipped: unclipped would be an iris floating over the cheek on exactly the
frames where the eye is missing." frames where the eye is missing."
[ops] [rank ops]
(let [by-id (into {} (map (juxt :node :color)) ops)] (let [by-id (into {} (map (juxt :node :color)) ops)]
(->> ops (->> ops
(keep (fn [op] (keep (fn [op]
@ -152,107 +169,134 @@
(when-let [idx (get by-id s)] (when-let [idx (get by-id s)]
(assoc op :stencil idx)) (assoc op :stencil idx))
op))) op)))
(sort op-compare) (sort-by (comp rank :node))
vec))) vec)))
(defn- n-points
"Points in a flat [x0 y0 x1 y1 …] value, authored vector or dense view alike."
[pts]
(quot (if (vector? pts) (count pts) (.-length pts)) 2))
(defn- xform-at
"The five transform components at the node's local frame, or nil when any of
them has no value on it."
[rd]
(let [pos (rd [:xform :pos])
rot (rd [:xform :rot])
scl (rd [:xform :scale])
skw (rd [:xform :skew])
anc (rd [:xform :anchor])]
(when-not (or (ch/nothing? pos) (ch/nothing? rot) (ch/nothing? scl)
(ch/nothing? skw) (ch/nothing? anc))
[pos rot scl skw anc])))
(defn- place
"Where a node sits this frame, as {:m world :f local-frame :rd reader}, or nil
when it is not on the frame at all.
Three gates, and nil from any of them removes the node's DESCENDANTS too,
which is why this is one answer rather than three flags: a node outside its
span does not exist, a switched-off feature takes its parts with it, and a node
with no transform gives its children nowhere to be.
A missing [:geom :pts] is deliberately NOT one of them — that is `emit`'s
business. An absent mouth outline has nothing to draw, but the head it hangs
off is still exactly where it was, and that asymmetry is the whole reason
presence is tracked per channel rather than per node."
[{:keys [read mat-for pinv-for scratch]} n parent f]
(let [pf (if parent (:f parent) f)]
(when (in-span? n pf)
(let [id (:id n)
chs (node/channels n)
lf (node/local-frame n pf)
rd (fn [path] (read id path (get chs path) lf))]
(when (true? (rd [:vis]))
(when-let [[pos rot scl skw anc] (xform-at rd)]
;; dest aliases `local` here, which mul! allows: it reads both
;; operands fully before writing either.
(let [m (node/local! (mat-for id) pos rot scl skw anc)]
{:m (node/world! m (:m parent) (pinv-for id) m scratch)
:f lf
:rd rd})))))))
(defn- emit
"The draw op for a placed node, or nil when it has nothing to draw. A group
never draws; it exists to carry a transform.
Three branches that rhyme, deliberately left as three: a poly writes vertices
into a buffer it was handed, a disc carries a scaled radius, a rect a rounded
pixel count. They are three different marks, and the shared skeleton is two
cheap lines each — folding them into one shape driven by a table would buy
those lines back by coupling this to whatever the table was for."
[{:keys [palette buf-for]} n {:keys [m rd]} base]
(let [colour #(colour-index palette (rd [:style :color]))]
(case (:kind n)
:group nil
:poly
(let [pts (rd [:geom :pts])]
(when-not (ch/nothing? pts)
(let [np (n-points pts)
out (buf-for (:id n) np)]
(dotimes [k np]
(node/apply-pt! out k m
(ch/component pts (* 2 k))
(ch/component pts (inc (* 2 k)))))
(assoc base :kind :poly :pts out :n np :color (colour)))))
:disc
(let [rad (rd [:geom :radius])]
(when-not (ch/nothing? rad)
(assoc base :kind :disc
:cx (aget m 4) :cy (aget m 5)
:r (* rad (node/mean-scale m))
:color (colour))))
:rect
(let [size (rd [:geom :size])]
(when-not (ch/nothing? size)
(assoc base :kind :rect
:cx (aget m 4) :cy (aget m 5)
;; ROUNDED, because :size is a pixel count: a scaled square
;; 3.4px wide would be 3px on one frame and 4 on the next,
;; which reads as the pupil breathing. See raster/fill-rect!.
:size (js/Math.round (* size (node/mean-scale m)))
:color (colour))))
(throw (ex-info "node kind is not implemented"
{:node (:id n) :kind (:kind n)})))))
(defn- eval-into (defn- eval-into
"The one frame evaluation, parameterised by how a channel is read and where its "One frame, as a fold over the nodes in topological order.
points are written.
read (fn [id path channel local-frame] -> v) `ctx` carries how a channel is read and where its points are written:
palette tone -> index, the ramp in scope
mat-for (fn [id] -> Float64Array) the node's world transform
pinv-for (fn [id] -> Float64Array|nil) its parent-inverse
buf-for (fn [id n-points] -> Float64Array)
scratch one spare 6-element matrix
Returns ops in z order." :read (fn [id path channel local-frame] -> v)
[nodes ord zpaths read palette mat-for pinv-for buf-for scratch f] :palette tone -> index, the ramp in scope
(let [cnt (count ord)] :mat-for (fn [id] -> Float64Array) the node's world transform
(loop [i 0, placed {}, ops []] :pinv-for (fn [id] -> Float64Array|nil) its parent-inverse
(if (= i cnt) :buf-for (fn [id n-points] -> Float64Array)
(finish ops) :scratch one spare 6-element matrix"
(let [id (nth ord i) [ctx nodes ord rank f]
n (get nodes id) (-> (reduce
pid (:parent n) (fn [{:keys [placed ops] :as acc} id]
parent (when pid (get placed pid))] (let [n (get nodes id)
;; A node whose parent was dropped is dropped with it, and so is pid (:parent n)
;; everything under it. Topological order is what makes that one parent (when pid (get placed pid))]
;; lookup instead of a subtree walk. ;; A node whose parent was dropped is dropped with it, and so is
(if (and pid (nil? parent)) ;; everything under it. Topological order is what makes that one
(recur (inc i) placed ops) ;; lookup instead of a subtree walk.
(let [pf (if parent (:f parent) f)] (if (and pid (nil? parent))
(if-not (in-span? n pf) acc
(recur (inc i) placed ops) (if-let [p (place ctx n parent f)]
(let [chs (node/channels n) (let [op (emit ctx n p {:node id :stencil (:stencil n)})]
lf (node/local-frame n pf) (cond-> (update acc :placed assoc id p)
rd (fn [path] (read id path (get chs path) lf)) op (update :ops conj op)))
vis (rd [:vis]) acc))))
pos (rd [:xform :pos]) {:placed {} :ops []}
rot (rd [:xform :rot]) ord)
scl (rd [:xform :scale]) :ops
skw (rd [:xform :skew]) (->> (finish rank))))
anc (rd [:xform :anchor])]
;; [:vis] and the transform gate the DESCENDANTS as well as the
;; node: a switched-off feature takes its parts with it, and a
;; node with no transform gives its children nowhere to be.
;;
;; A missing [:geom :pts] does NOT gate descendants. An absent
;; mouth outline has nothing to draw, but the head it hangs off
;; is still exactly where it was. That asymmetry is the whole
;; reason presence is tracked per channel rather than per node.
(if-not (and (true? vis)
(not (ch/nothing? pos)) (not (ch/nothing? rot))
(not (ch/nothing? scl)) (not (ch/nothing? skw))
(not (ch/nothing? anc)))
(recur (inc i) placed ops)
;; dest aliases `local` here, which mul! allows: it reads both
;; operands fully before writing either.
(let [m (node/local! (mat-for id) pos rot scl skw anc)
m (node/world! m (:m parent) (pinv-for id) m scratch)
base {:i i :z-path (get zpaths id) :node id
:stencil (:stencil n)}
op (case (:kind n)
:group nil
:poly
(let [pts (rd [:geom :pts])]
(when-not (ch/nothing? pts)
(let [np (quot (if (vector? pts) (count pts) (.-length pts)) 2)
out (buf-for id np)]
(dotimes [k np]
(node/apply-pt! out k m
(ch/component pts (* 2 k))
(ch/component pts (inc (* 2 k)))))
(assoc base :kind :poly :pts out :n np
:color (colour-index palette (rd [:style :color]))))))
:disc
(let [rad (rd [:geom :radius])]
(when-not (ch/nothing? rad)
(assoc base :kind :disc
:cx (aget m 4) :cy (aget m 5)
:r (* rad (node/mean-scale m))
:color (colour-index palette (rd [:style :color])))))
:rect
(let [size (rd [:geom :size])]
(when-not (ch/nothing? size)
(assoc base :kind :rect
:cx (aget m 4) :cy (aget m 5)
;; ROUNDED, because :size is a pixel
;; count: a scaled square 3.4px wide
;; would be 3px on one frame and 4 on
;; the next, which reads as the pupil
;; breathing. See raster/fill-rect!.
:size (js/Math.round (* size (node/mean-scale m)))
:color (colour-index palette (rd [:style :color])))))
(throw (ex-info "node kind is not implemented"
{:node id :kind (:kind n)})))]
(recur (inc i)
(assoc placed id {:m m :f lf})
(cond-> ops op (conj op))))))))))))))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; the specification ;; the specification
@ -264,17 +308,15 @@
([scene f] (eval-frame scene f nil pal/index-of)) ([scene f] (eval-frame scene f nil pal/index-of))
([scene f store] (eval-frame scene f store pal/index-of)) ([scene f store] (eval-frame scene f store pal/index-of))
([scene f store palette] ([scene f store palette]
(let [nodes (:nodes scene) (let [nodes (:nodes scene)
ord (order nodes) ord (order nodes)]
zpaths (into {} (map (fn [id] [id (z-path nodes id)])) ord)] (eval-into {:read (fn [_id _path c lf] (ch/value-at c lf store))
(eval-into nodes ord zpaths :palette palette
(fn [_id _path c lf] (ch/value-at c lf store)) :mat-for (fn [_id] (node/mat))
palette :pinv-for (fn [id] (node/pinv (get nodes id)))
(fn [_id] (node/mat)) :buf-for (fn [_id n] (js/Float64Array. (* 2 n)))
(fn [id] (node/pinv (get nodes id))) :scratch (node/mat)}
(fn [_id n] (js/Float64Array. (* 2 n))) nodes ord (draw-rank nodes ord) f))))
(node/mat)
f))))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; the playback path ;; the playback path
@ -323,7 +365,7 @@
([scene store palette] ([scene store palette]
(let [nodes (:nodes scene) (let [nodes (:nodes scene)
ord (order nodes) ord (order nodes)
zpaths (into {} (map (fn [id] [id (z-path nodes id)])) ord) rank (draw-rank nodes ord)
cursors (into {} cursors (into {}
(map (fn [id] (map (fn [id]
[id (into {} (map (fn [[p c]] [p (ch/cursor c store)])) [id (into {} (map (fn [[p c]] [p (ch/cursor c store)]))
@ -343,16 +385,15 @@
;; eval-into having to report it — and it covers groups, which are ;; eval-into having to report it — and it covers groups, which are
;; placed but emit no op, and which are exactly what an underlay rides. ;; placed but emit no op, and which are exactly what an underlay rides.
placed (volatile! #{}) placed (volatile! #{})
ctx {:read (fn [id path _c lf] (ch/sample! (get-in cursors [id path]) lf))
:palette palette
:mat-for (fn [id] (vswap! placed conj id) (get mats id))
:pinv-for (fn [id] (get pinvs id))
:buf-for (fn [id _n] (get bufs id))
:scratch scratch}
step (fn [f] step (fn [f]
(vreset! placed #{}) (vreset! placed #{})
(eval-into nodes ord zpaths (eval-into ctx nodes ord rank f))]
(fn [id path _c lf] (ch/sample! (get-in cursors [id path]) lf))
palette
(fn [id] (vswap! placed conj id) (get mats id))
(fn [id] (get pinvs id))
(fn [id _n] (get bufs id))
scratch
f))]
(reify (reify
IFn IFn
(-invoke [_ f] (step f)) (-invoke [_ f] (step f))
@ -391,5 +432,3 @@
nil nil
(catch :default e [(ex-message e)]))))))) (catch :default e [(ex-message e)])))))))
(defn problems-str [scene]
(str/join "; " (problems scene)))

29
frontend/test/arthur/domain/raster_test.cljs
View file

@ -189,3 +189,32 @@
(is (= #{0 1 2 4} (set (array-seq (:buf ras))))) (is (= #{0 1 2 4} (set (array-seq (:buf ras)))))
(is (thrown-with-msg? ExceptionInfo #"not rasterisable" (is (thrown-with-msg? ExceptionInfo #"not rasterisable"
(r/draw-ops! ras [{:kind :bitmap}]))))) (r/draw-ops! ras [{:kind :bitmap}])))))
(deftest rgba-matches-a-naive-reference-at-every-zoom
;; The fast path writes one 32-bit word per pixel through a Uint32Array view,
;; which is a very different thing from the four byte writes it replaced. A
;; mistake in it — a channel order, an endianness assumption, an off-by-one on
;; the row — would present as a palette bug rather than as an optimisation, so
;; it is pinned against the obvious implementation rather than trusted.
(let [naive (fn [{:keys [w h buf]} palette zoom]
(let [W (* w zoom) H (* h zoom)
d (js/Uint8ClampedArray. (* W H 4))]
(dotimes [y H]
(dotimes [x W]
(let [c (or (nth palette (aget buf (+ (* (quot y zoom) w) (quot x zoom))) nil)
[255 0 255])
o (* (+ (* y W) x) 4)]
(aset d o (nth c 0)) (aset d (+ o 1) (nth c 1))
(aset d (+ o 2) (nth c 2)) (aset d (+ o 3) 255))))
(vec (array-seq d))))
ras (r/make 23 17)] ; deliberately not a round size
(dotimes [i (* 23 17)]
(aset (:buf ras) i (if (zero? (mod i 13)) 200 (mod i (count pal/rgb)))))
(doseq [zoom [1 2 3]]
(is (= (naive ras pal/rgb zoom)
(vec (array-seq (:data (r/->rgba ras pal/rgb zoom)))))
(str "zoom " zoom)))
(testing "and writing into a caller's buffer gives the same bytes"
(let [dest (js/Uint8ClampedArray. (* 23 17 4))]
(is (= (naive ras pal/rgb 1)
(vec (array-seq (:data (r/->rgba ras pal/rgb 1 dest))))))))))

3
frontend/test/arthur/domain/scene_test.cljs
View file

@ -291,7 +291,8 @@
;; ---- the hand-written scene, end to end ---- ;; ---- the hand-written scene, end to end ----
(deftest the-hand-written-scene-is-valid (deftest the-hand-written-scene-is-valid
(is (= "" (scene/problems-str demo/scene))) (let [ps (scene/problems demo/scene)]
(is (empty? ps) (pr-str ps)))
(is (pos? (:frames demo/scene)))) (is (pos? (:frames demo/scene))))
(deftest the-hand-written-scene-renders-and-moves (deftest the-hand-written-scene-renders-and-moves