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
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
the flag on the node would forbid the most useful thing in the model."
(:require [clojure.string :as str]))
the flag on the node would forbid the most useful thing in the model.")
;; ---------------------------------------------------------------------------
;; the state mask
@ -284,5 +283,3 @@
(and (map? ch) (seq (:over ch)))
(conj ":over layers are not implemented (port-plan step 2 scope)")))
(defn problems-str [ch]
(str/join "; " (problems ch)))

74
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
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
"Least-squares similarity (translation + rotation + uniform scale, 4 DOF)
mapping P onto Q. Closed form; no iteration.
@ -16,23 +23,23 @@
pitch as a measurable residual."
[P Q]
(let [n (count P)
[pcx pcy qcx qcy]
(loop [i 0, pcx 0.0, pcy 0.0, qcx 0.0, qcy 0.0]
(if (< i n)
(recur (inc i)
(+ pcx (:x (nth P i))) (+ pcy (:y (nth P i)))
(+ qcx (:x (nth Q i))) (+ qcy (:y (nth Q i))))
[(/ pcx n) (/ pcy n) (/ qcx n) (/ qcy n)]))
cp (centroid P)
cq (centroid Q)
;; Dot, cross and squared norm of the centred configurations, in one
;; pass. Reduced in input order, so the floating-point result is bit for
;; bit what an index loop would give and the 1e-9 parity against the JS
;; holds.
[a b norm]
(loop [i 0, a 0.0, b 0.0, norm 0.0]
(if (< i n)
(let [px (- (:x (nth P i)) pcx) py (- (:y (nth P i)) pcy)
qx (- (:x (nth Q i)) qcx) qy (- (:y (nth Q i)) qcy)]
(recur (inc i)
(+ a (+ (* px qx) (* py qy))) ; dot
(reduce (fn [[a b norm] [p q]]
(let [px (- (:x p) (:x cp)) py (- (:y p) (:y cp))
qx (- (:x q) (:x cq)) qy (- (:y q) (:y cq))]
[(+ a (+ (* px qx) (* py qy))) ; dot
(+ b (- (* px qy) (* py qx))) ; cross
(+ norm (+ (* px px) (* py py)))))
[a b norm]))
(+ norm (+ (* px px) (* py py)))]))
[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)
;; A degenerate configuration has nothing to recover a scale from. Fall
;; 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
rotation, so it is the signal for \"this section is not stabilisable\"."
[tf P Q]
(let [n (count P)]
(let [sq (fn [d] (* d d))]
(js/Math.sqrt
(/ (loop [i 0, acc 0.0]
(if (< i n)
(let [m (apply-sim tf (nth P i))
q (nth Q i)]
(recur (inc i)
(+ acc (js/Math.pow (- (:x m) (:x q)) 2)
(js/Math.pow (- (:y m) (:y q)) 2))))
acc))
n))))
(/ (transduce (map (fn [[p q]]
(let [m (apply-sim tf p)]
(+ (sq (- (:x m) (:x q)))
(sq (- (:y m) (:y q)))))))
+ 0.0 (map vector P Q))
(count P)))))
(defn procrustes-mean
"Generalised Procrustes: the reference is the MEAN rigid configuration over the
@ -76,20 +80,22 @@
other frame. Three passes is plenty."
([frames-rigid] (procrustes-mean frames-rigid 3))
([frames-rigid iters]
(let [n (count frames-rigid)]
(loop [ref (mapv (fn [p] {:x (:x p) :y (:y p)}) (nth frames-rigid 0))
iter 0]
(if (= iter iters)
ref
(recur
(let [n (count frames-rigid)
;; One pass: fit every frame onto the current reference, sum the
;; aligned configurations, divide. Iterative refinement, so the whole
;; thing is `iterate` taken `iters` deep — which is what the algorithm
;; actually says, rather than a counter that happens to stop.
refine (fn [ref]
(->> frames-rigid
(reduce (fn [acc 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))
:y (+ (:y a) (:y m))})
acc moved)))
(mapv (constantly {:x 0.0 :y 0.0}) ref))
(mapv (fn [p] {:x (/ (:x p) n) :y (/ (:y p) n)})))
(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
"`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
matrix shears on the way. Flat Float64Array for evaluation because at 30fps
per-frame allocation is the only thing that will make this stutter."
(:require [arthur.domain.channel :as ch]
[clojure.string :as str]))
(:require [arthur.domain.channel :as ch]))
(def kinds
"`:symbol` and `:bitmap` are in the vocabulary and not implemented; they are
@ -38,14 +37,19 @@
(def valid-paths
"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
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)]
{:group base
:poly (into base [[:geom :pts] [:style :color]])
;; 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.
;; 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 it can be keyed.
: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!.
:rect (into base [[:geom :size] [:style :color]])}))
@ -253,5 +257,3 @@
p (ch/problems c)]
(str "channel " (pr-str path) ": " p))))))
(defn problems-str [n]
(str/join "; " (problems n)))

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

@ -40,41 +40,45 @@
(when (>= n 3)
(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)))))
xs (array)]
(let [ymin (loop [i 1, acc (py 0)] (if (< i n) (recur (inc i) (min acc (py i))) acc))
ymax (loop [i 1, acc (py 0)] (if (< i n) (recur (inc i) (max acc (py i))) acc))
y0 (max 0 (js/Math.ceil (- ymin 0.5)))
y1 (min (dec h) (inc (js/Math.floor (- ymax 0.5))))]
(loop [y y0]
(when (<= y y1)
(let [sy (+ y 0.5)]
xs (array)
ys (map py (range n))
y0 (max 0 (js/Math.ceil (- (reduce min ys) 0.5)))
y1 (min (dec h) (inc (js/Math.floor (- (reduce max ys) 0.5))))]
;; `dotimes` over the span rather than a hand-rolled index: bounded
;; iteration with no accumulator is what it is for, and it compiles to the
;; same JS for-loop the recur did.
(dotimes [dy (inc (- y1 y0))]
(let [y (+ y0 dy)
sy (+ y 0.5)]
(set! (.-length xs) 0)
(dotimes [i n]
(let [j (mod (inc i) n)
ay (py i) by (py j)]
;; A horizontal edge contributes no crossing, and dividing by
;; its zero height would emit Infinity.
;; A horizontal edge contributes no crossing, and dividing by its
;; zero height would emit Infinity.
(when (not= ay by)
(let [lo (min ay by) hi (max ay by)]
;; Half-open in y: >= lo and < hi. A vertex shared by two
;; edges is counted exactly once, so the parity cannot flip
;; at a corner and leak a whole scanline.
;; Half-open in y: >= lo and < hi. A vertex shared by two edges
;; is counted exactly once, so the parity cannot flip at a
;; corner and leak a whole scanline.
(when (and (>= sy lo) (< sy hi))
(.push xs (+ (px i) (* (/ (- sy ay) (- by ay))
(- (px j) (px i))))))))))
(when (>= (.-length xs) 2)
(.sort xs (fn [a b] (- a b)))
(loop [k 0]
(when (< (inc k) (.-length xs))
(let [x-from (max 0 (js/Math.ceil (- (aget xs k) 0.5)))
x-to (min (dec w) (js/Math.floor (- (aget xs (inc k)) 0.5)))
;; Crossings pair up left to right: inside a span, outside the next.
;; Iterated as PAIRS rather than as a stepped index, but over the
;; array directly — `partition 2` over an `array-seq` says the same
;; thing and allocates two seqs per scanline, which is some five
;; thousand throwaway objects a frame in the hottest loop here.
(dotimes [k (quot (.-length xs) 2)]
(let [xa (aget xs (* 2 k))
xb (aget xs (inc (* 2 k)))
x-from (max 0 (js/Math.ceil (- xa 0.5)))
x-to (min (dec w) (js/Math.floor (- xb 0.5)))
row (* y w)]
(loop [x x-from]
(when (<= x x-to)
(aset buf (+ row x) index)
(recur (inc x)))))
(recur (+ k 2))))))
(recur (inc y)))))))
(dotimes [dx (inc (- x-to x-from))]
(aset buf (+ row x-from dx) index)))))))))
r)
(defn fill-poly!
@ -85,14 +89,7 @@
scanline implementation serves both, because two would drift and the drift
would read as a rendering bug rather than as two functions disagreeing."
[r pts index]
(let [n (count pts)
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)))
(fill-poly-buf! r (into-array (mapcat (juxt :x :y) pts)) (count pts) index))
(defn fill-disc!
"`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)))
x0 (max 0 (js/Math.floor (- cx rad)))
x1 (min (dec w) (js/Math.ceil (+ cx rad)))]
(loop [y y0]
(when (<= y y1)
(loop [x x0]
(when (<= x x1)
(let [dx (- (+ x 0.5) cx)
(dotimes [iy (inc (- y1 y0))]
(dotimes [ix (inc (- x1 x0))]
(let [x (+ x0 ix)
y (+ y0 iy)
dx (- (+ x 0.5) cx)
dy (- (+ y 0.5) cy)]
(when (<= (+ (* dx dx) (* dy dy)) rr)
(let [o (+ (* y w) x)]
(when (or (nil? over) (= (aget buf o) over))
(aset buf o index)))))
(recur (inc x))))
(recur (inc y))))
(aset buf o index)))))))
r)))
(defn fill-rect!
@ -142,50 +137,89 @@
(when (>= size 1)
(let [x0 (js/Math.round (- cx (/ size 2)))
y0 (js/Math.round (- cy (/ size 2)))]
(loop [y (max 0 y0)]
(when (< y (min h (+ y0 size)))
(loop [x (max 0 x0)]
(when (< x (min w (+ x0 size)))
(let [o (+ (* y w) x)]
(let [ya (max 0 y0) yb (min h (+ y0 size))
xa (max 0 x0) xb (min w (+ x0 size))]
(dotimes [iy (- yb ya)]
(dotimes [ix (- xb xa)]
(let [o (+ (* (+ ya iy) w) xa ix)]
(when (or (nil? over) (= (aget buf o) over))
(aset buf o index)))
(recur (inc x))))
(recur (inc y))))))
(aset buf o index))))))))
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
"Expand indices through the palette at integer zoom. Nearest-neighbour by
construction, so no filtering softens the result.
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
transparent or black: writing an index the palette does not have is a bug, and
it should be impossible to miss.
an ImageData.
`dest` is an optional Uint8ClampedArray to write into instead of allocating
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
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 zoom] (->rgba r palette-rgb zoom nil))
([{:keys [w h buf]} palette-rgb zoom dest]
(let [W (* w zoom)
H (* h zoom)
d (or dest (js/Uint8ClampedArray. (* W H 4)))]
(loop [y 0]
(when (< y H)
d (or dest (js/Uint8ClampedArray. (* W H 4)))
{:keys [p8 p32]} (flatten-palette palette-rgb)]
(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)]
(loop [x 0]
(when (< x W)
(let [c (or (nth palette-rgb (aget buf (+ srow (js/Math.floor (/ x zoom)))) nil)
[255 0 255])
(dotimes [x W]
(let [p (* 3 (aget buf (+ srow (js/Math.floor (/ x zoom)))))
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))
(recur (inc x)))))
(recur (inc y))))
(aset d o (aget p8 p))
(aset d (+ o 1) (aget p8 (+ p 1)))
(aset d (+ o 2) (aget p8 (+ p 2)))
(aset d (+ o 3) 255))))))
{:width W :height H :data d})))
(defn draw-ops!

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

@ -29,26 +29,38 @@
fill in the same channel rather than convert into a second format."
(:require [arthur.domain.channel :as ch]
[arthur.domain.node :as node]
[arthur.domain.palette :as pal]
[clojure.string :as str]))
[arthur.domain.palette :as pal]))
;; ---------------------------------------------------------------------------
;; structure: depth, topological order, draw order
(defn depth
"Number of ancestors. Throws on a parent cycle rather than looping forever — a
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."
(defn lineage
"The node's id and every ancestor's, nearest first and root last.
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]
(loop [id id, d 0, seen #{}]
(let [p (:parent (get nodes id))]
(cond
(nil? p) d
(contains? seen p)
(throw (ex-info "parent cycle in scene" {:node id :cycle (conj seen p)}))
(nil? (get nodes p))
(throw (ex-info "node's :parent is not in the scene" {:node id :parent p}))
:else (recur p (inc d) (conj seen p))))))
(let [up (fn [i]
(when-let [p (:parent (get nodes i))]
(if (contains? nodes p)
p
(throw (ex-info "node's :parent is not in the scene"
{:node i :parent p})))))
chain (into [] (comp (take-while some?) (take (inc (count nodes))))
(iterate up id))]
(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
"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,
which matters because the draw-order sort below falls back on this position."
[nodes]
(vec (sort-by (juxt #(depth nodes %) #(str %)) (keys nodes))))
(vec (sort-by (juxt #(depth nodes %) str) (keys nodes))))
(defn z-path
"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
without renumbering either."
[nodes id]
(loop [id id, acc ()]
(if (nil? id)
(vec acc)
(let [n (get nodes id)]
(recur (:parent n) (conj acc (:z n)))))))
(mapv #(:z (get nodes %)) (rseq (lineage nodes id))))
(defn- z-lex
"Lexicographic compare of two z paths, a prefix sorting first.
`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
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))))))
jump in front of the head that carries it.
(defn- op-compare [x y]
(let [c (z-lex (:z-path x) (:z-path y))]
(if (zero? c) (- (:i x) (:i y)) c)))
`map` over two collections stops at the shorter and `first` short-circuits at
the first difference, so this walks no further than it has to."
[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
@ -144,7 +161,7 @@
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
frames where the eye is missing."
[ops]
[rank ops]
(let [by-id (into {} (map (juxt :node :color)) ops)]
(->> ops
(keep (fn [op]
@ -152,80 +169,80 @@
(when-let [idx (get by-id s)]
(assoc op :stencil idx))
op)))
(sort op-compare)
(sort-by (comp rank :node))
vec)))
(defn- eval-into
"The one frame evaluation, parameterised by how a channel is read and where its
points are written.
(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))
read (fn [id path channel local-frame] -> v)
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."
[nodes ord zpaths read palette mat-for pinv-for buf-for scratch f]
(let [cnt (count ord)]
(loop [i 0, placed {}, ops []]
(if (= i cnt)
(finish ops)
(let [id (nth ord i)
n (get nodes id)
pid (:parent n)
parent (when pid (get placed pid))]
;; A node whose parent was dropped is dropped with it, and so is
;; everything under it. Topological order is what makes that one
;; lookup instead of a subtree walk.
(if (and pid (nil? parent))
(recur (inc i) placed ops)
(let [pf (if parent (:f parent) f)]
(if-not (in-span? n pf)
(recur (inc i) placed ops)
(let [chs (node/channels n)
lf (node/local-frame n pf)
rd (fn [path] (read id path (get chs path) lf))
vis (rd [:vis])
pos (rd [:xform :pos])
(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])]
;; [: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)
(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)
base {:i i :z-path (get zpaths id) :node id
:stencil (:stencil n)}
op (case (:kind n)
(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 (quot (if (vector? pts) (count pts) (.-length pts)) 2)
out (buf-for id np)]
(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-index palette (rd [:style :color]))))))
(assoc base :kind :poly :pts out :n np :color (colour)))))
:disc
(let [rad (rd [:geom :radius])]
@ -233,26 +250,53 @@
(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])))))
: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!.
;; 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])))))
:color (colour))))
(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))))))))))))))
{:node (:id n) :kind (:kind n)})))))
(defn- eval-into
"One frame, as a fold over the nodes in topological order.
`ctx` carries how a channel is read and where its points are written:
:read (fn [id path channel local-frame] -> v)
: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"
[ctx nodes ord rank f]
(-> (reduce
(fn [{:keys [placed ops] :as acc} id]
(let [n (get nodes id)
pid (:parent n)
parent (when pid (get placed pid))]
;; A node whose parent was dropped is dropped with it, and so is
;; everything under it. Topological order is what makes that one
;; lookup instead of a subtree walk.
(if (and pid (nil? parent))
acc
(if-let [p (place ctx n parent f)]
(let [op (emit ctx n p {:node id :stencil (:stencil n)})]
(cond-> (update acc :placed assoc id p)
op (update :ops conj op)))
acc))))
{:placed {} :ops []}
ord)
:ops
(->> (finish rank))))
;; ---------------------------------------------------------------------------
;; the specification
@ -265,16 +309,14 @@
([scene f store] (eval-frame scene f store pal/index-of))
([scene f store palette]
(let [nodes (:nodes scene)
ord (order nodes)
zpaths (into {} (map (fn [id] [id (z-path nodes id)])) ord)]
(eval-into nodes ord zpaths
(fn [_id _path c lf] (ch/value-at c lf store))
palette
(fn [_id] (node/mat))
(fn [id] (node/pinv (get nodes id)))
(fn [_id n] (js/Float64Array. (* 2 n)))
(node/mat)
f))))
ord (order nodes)]
(eval-into {:read (fn [_id _path c lf] (ch/value-at c lf store))
:palette palette
:mat-for (fn [_id] (node/mat))
:pinv-for (fn [id] (node/pinv (get nodes id)))
:buf-for (fn [_id n] (js/Float64Array. (* 2 n)))
:scratch (node/mat)}
nodes ord (draw-rank nodes ord) f))))
;; ---------------------------------------------------------------------------
;; the playback path
@ -323,7 +365,7 @@
([scene store palette]
(let [nodes (:nodes scene)
ord (order nodes)
zpaths (into {} (map (fn [id] [id (z-path nodes id)])) ord)
rank (draw-rank nodes ord)
cursors (into {}
(map (fn [id]
[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
;; placed but emit no op, and which are exactly what an underlay rides.
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]
(vreset! placed #{})
(eval-into nodes ord zpaths
(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))]
(eval-into ctx nodes ord rank f))]
(reify
IFn
(-invoke [_ f] (step f))
@ -391,5 +432,3 @@
nil
(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 (thrown-with-msg? ExceptionInfo #"not rasterisable"
(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 ----
(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))))
(deftest the-hand-written-scene-renders-and-moves