e22ee600b9
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com> Claude-Session: https://claude.ai/code/session_016JBYKfeMPQTK1WNcgcw41o
227 lines
11 KiB
Clojure
227 lines
11 KiB
Clojure
(ns arthur.domain.png-test
|
|
"The encoder, asserted by DECODING what it wrote.
|
|
|
|
This file reads the bytes back — chunk framing, CRCs, inflate, un-filter — and
|
|
compares the recovered pixels against the ramp expansion they are supposed to
|
|
be. Anything weaker would not be worth writing. The claim `domain/png` makes is
|
|
bit-exactness: the file holds the bytes `raster/draw-ops!` produced, expanded
|
|
through the ramp at an integer zoom, with nothing resampling or smoothing on the
|
|
way. A test that only checked the header would pass on a file whose every pixel
|
|
was wrong, and a test that only checked it parses would pass on one the encoder
|
|
and this test agreed to get wrong together. So the inflate here is node's own
|
|
`DecompressionStream` and the un-filter is written out longhand from the spec.
|
|
|
|
It is also the test that catches the encoder not running at all. The first
|
|
version of `deflate!` piped a `Blob` instead of the Blob's `.stream`, so every
|
|
export died at the first frame with `pipeThrough is not a function` — reachable
|
|
only by encoding something, which nothing under node did until this file."
|
|
(:require [cljs.test :refer [deftest is testing async]]
|
|
[arthur.domain.crc32 :as crc32]
|
|
[arthur.domain.png :as png]
|
|
[arthur.domain.raster :as raster]))
|
|
|
|
;; A ramp with no two entries alike, so a pixel that lands on the wrong index
|
|
;; cannot pass by holding a colour that happens to match its neighbour's.
|
|
(def ^:private ramp
|
|
(mapv (fn [i] [(* 10 i) (+ 1 (* 10 i)) (+ 2 (* 10 i))]) (range 16)))
|
|
|
|
(defn- chunks
|
|
"The file's chunks as [{:type :data :crc :crc-ok?}], after the signature."
|
|
[^js b]
|
|
(let [u32 (fn [at] (-> (+ (bit-shift-left (aget b at) 24)
|
|
(bit-shift-left (aget b (+ at 1)) 16)
|
|
(bit-shift-left (aget b (+ at 2)) 8)
|
|
(aget b (+ at 3)))
|
|
(unsigned-bit-shift-right 0)))]
|
|
(loop [at 8 acc []]
|
|
(if (>= at (.-length b))
|
|
acc
|
|
(let [n (u32 at)
|
|
tag (apply str (map #(char (aget b (+ at 4 %))) (range 4)))
|
|
data (.subarray b (+ at 8) (+ at 8 n))
|
|
crc (u32 (+ at 8 n))]
|
|
(recur (+ at 12 n)
|
|
(conj acc {:type tag :data data :crc crc
|
|
;; Over the TYPE and payload, not the length — which
|
|
;; is the detail a hand-rolled chunk writer gets wrong.
|
|
:crc-ok? (= crc (crc32/of b (+ at 4) (+ at 8 n)))})))))))
|
|
|
|
(defn- inflate!
|
|
[^js bytes]
|
|
(-> (js/Response. (.pipeThrough (.stream (js/Blob. #js [bytes]))
|
|
(js/DecompressionStream. "deflate")))
|
|
(.arrayBuffer)
|
|
(.then #(js/Uint8Array. %))))
|
|
|
|
(defn- unfilter
|
|
"Undo the per-row filters of an inflated PNG. Returns the rows as vectors of
|
|
bytes. Only filter 0 (None) and 2 (Up) are handled; anything else is a bug in
|
|
the encoder rather than something to be lenient about, so it throws."
|
|
[^js raw w h]
|
|
(let [stride (* w 3)]
|
|
(loop [y 0 prev (vec (repeat stride 0)) acc []]
|
|
(if (= y h)
|
|
acc
|
|
(let [at (* y (inc stride))
|
|
f (aget raw at)
|
|
_ (when-not (#{0 2} f)
|
|
(throw (ex-info "unexpected PNG filter type" {:row y :filter f})))
|
|
row (mapv (fn [i]
|
|
(let [s (aget raw (+ at 1 i))]
|
|
(bit-and (if (= f 2) (+ s (nth prev i)) s) 0xff)))
|
|
(range stride))]
|
|
(recur (inc y) row (conj acc row)))))))
|
|
|
|
(defn- decoded
|
|
"Promise of {:w :h :rows}, the encoder's output read back as RGB rows."
|
|
[^js file w h zoom]
|
|
(let [cs (chunks file)
|
|
ihdr (:data (first (filter #(= "IHDR" (:type %)) cs)))
|
|
idat (:data (first (filter #(= "IDAT" (:type %)) cs)))]
|
|
(-> (inflate! idat)
|
|
(.then (fn [raw]
|
|
{:chunks cs
|
|
:ihdr ihdr
|
|
:rows (unfilter raw (* w zoom) (* h zoom))})))))
|
|
|
|
(defn- try!
|
|
"Call `f`, turning a SYNCHRONOUS throw into a rejected promise.
|
|
|
|
`png/encoder`'s returned function does the whole of its pixel work before it
|
|
returns a promise, so a failure in there throws rather than rejecting, and an
|
|
uncaught throw out of a `deftest` body aborts the entire node suite at this
|
|
namespace — which is how the `pipeThrough` bug presented: 250 unrelated tests
|
|
stopped reporting. Routing it through a rejection keeps the blast radius to the
|
|
one test and leaves the `.catch` below as the single place failures land."
|
|
[f]
|
|
(try (js/Promise.resolve (f))
|
|
(catch :default e (js/Promise.reject e))))
|
|
|
|
(defn- ras
|
|
"A small raster whose indices are all different from each other, so a
|
|
transposed or off-by-one read cannot look right."
|
|
[w h]
|
|
(let [r (raster/make w h)]
|
|
(dotimes [y h]
|
|
(dotimes [x w]
|
|
(aset (:buf r) (+ (* y w) x) (mod (+ 1 x (* 3 y)) 16))))
|
|
r))
|
|
|
|
(deftest the-file-is-a-png
|
|
(async done
|
|
(let [r (ras 4 3)]
|
|
(-> (try! #((png/encoder 4 3 1) r ramp))
|
|
(.then (fn [file]
|
|
(testing "signature"
|
|
(is (= [0x89 0x50 0x4e 0x47 0x0d 0x0a 0x1a 0x0a]
|
|
(mapv #(aget file %) (range 8)))))
|
|
(let [cs (chunks file)]
|
|
(testing "chunk order: IHDR first, IEND last, one IDAT"
|
|
(is (= ["IHDR" "IDAT" "IEND"] (mapv :type cs))))
|
|
(testing "every chunk's CRC covers type and payload"
|
|
(doseq [c cs]
|
|
(is (:crc-ok? c) (str (:type c) " CRC")))))
|
|
(done)))
|
|
(.catch (fn [e] (is false (str "encode threw: " e)) (done)))))))
|
|
|
|
(deftest the-ihdr-declares-truecolour-at-the-zoomed-size
|
|
(async done
|
|
(-> (-> (try! #((png/encoder 4 3 3) (ras 4 3) ramp))
|
|
(.then #(decoded % 4 3 3)))
|
|
(.then (fn [{:keys [ihdr]}]
|
|
;; Width and height are the ZOOMED size: the zoom is baked into
|
|
;; the file, not left as a flag for a reader to honour.
|
|
(is (= 12 (aget ihdr 3)) "width")
|
|
(is (= 9 (aget ihdr 7)) "height")
|
|
(is (= 8 (aget ihdr 8)) "bit depth")
|
|
(is (= 2 (aget ihdr 9)) "colour type 2, truecolour")
|
|
(is (= 0 (aget ihdr 10)) "compression: deflate")
|
|
(is (= 0 (aget ihdr 11)) "filter method: adaptive")
|
|
(is (= 0 (aget ihdr 12)) "no interlace")
|
|
(done)))
|
|
(.catch (fn [e] (is false (str "threw: " e)) (done))))))
|
|
|
|
(deftest every-pixel-is-its-ramp-entry
|
|
;; The bit-exactness claim, at zoom 1: no filtering, no subsampling, no colour
|
|
;; management — the byte in the buffer indexes the ramp and the ramp's RGB is
|
|
;; what lands in the file.
|
|
(async done
|
|
(let [r (ras 5 4)]
|
|
(-> (-> (try! #((png/encoder 5 4 1) r ramp))
|
|
(.then #(decoded % 5 4 1)))
|
|
(.then (fn [{:keys [rows]}]
|
|
(is (= 4 (count rows)) "one row per source row")
|
|
(doseq [y (range 4) x (range 5)]
|
|
(let [want (nth ramp (aget (:buf r) (+ (* y 5) x)))
|
|
got [(nth (nth rows y) (* 3 x))
|
|
(nth (nth rows y) (+ 1 (* 3 x)))
|
|
(nth (nth rows y) (+ 2 (* 3 x)))]]
|
|
(is (= want got) (str "pixel " x "," y))))
|
|
(done)))
|
|
(.catch (fn [e] (is false (str "threw: " e)) (done)))))))
|
|
|
|
(deftest the-zoom-duplicates-pixels-and-interpolates-nothing
|
|
;; The other half of the claim. At zoom 3 each source pixel must be a 3x3 block
|
|
;; of the IDENTICAL colour. Any smoothing shows up as a block whose corners
|
|
;; differ from its centre, and any colour not in the ramp is interpolation.
|
|
(async done
|
|
(let [zoom 3 w 5 h 4
|
|
r (ras w h)]
|
|
(-> (-> (try! #((png/encoder w h zoom) r ramp))
|
|
(.then #(decoded % w h zoom)))
|
|
(.then (fn [{:keys [rows]}]
|
|
(is (= (* h zoom) (count rows)) "one row per zoomed row")
|
|
(doseq [y (range h) x (range w)]
|
|
(let [want (nth ramp (aget (:buf r) (+ (* y w) x)))
|
|
block (for [dy (range zoom) dx (range zoom)]
|
|
(let [row (nth rows (+ (* y zoom) dy))
|
|
px (* 3 (+ (* x zoom) dx))]
|
|
[(nth row px) (nth row (+ px 1)) (nth row (+ px 2))]))]
|
|
(is (= #{want} (set block))
|
|
(str "the " zoom "x" zoom " block at " x "," y
|
|
" should be one colour: " (pr-str (set block))))))
|
|
(testing "and no colour outside the ramp appears anywhere"
|
|
(let [seen (set (for [row rows x (range (/ (count row) 3))]
|
|
[(nth row (* 3 x)) (nth row (+ 1 (* 3 x)))
|
|
(nth row (+ 2 (* 3 x)))]))]
|
|
(is (empty? (remove (set ramp) seen))
|
|
(pr-str (remove (set ramp) seen)))))
|
|
(done)))
|
|
(.catch (fn [e] (is false (str "threw: " e)) (done)))))))
|
|
|
|
(deftest a-flat-frame-costs-almost-nothing
|
|
;; Why filter Up is chosen, made an assertion rather than a claim in a comment:
|
|
;; a single-colour stage at zoom 4 is duplicate scanlines, Up turns all but the
|
|
;; first into runs of zeros, and deflate takes those to nearly nothing. If this
|
|
;; ratio collapses, the filter or the row order has changed and every export
|
|
;; got many times bigger.
|
|
(async done
|
|
(let [w 64 h 64 zoom 4
|
|
flat (raster/clear! (raster/make w h) 7)]
|
|
(-> (try! #((png/encoder w h zoom) flat ramp))
|
|
(.then (fn [file]
|
|
(let [raw (* w zoom h zoom 3)]
|
|
(is (< (.-length file) (/ raw 100))
|
|
(str (.-length file) " bytes for " raw " raw")))
|
|
(done)))
|
|
(.catch (fn [e] (is false (str "threw: " e)) (done)))))))
|
|
|
|
(deftest the-encoder-is-reusable-across-frames
|
|
;; The export loop holds ONE encoder and feeds it every frame, because the
|
|
;; scratch inside it is megabytes. So the scratch must not leak between frames:
|
|
;; encoding a, then b, then a again has to give byte-identical files for the two
|
|
;; a's. A `prev` row left dirty from the previous frame fails exactly here.
|
|
(async done
|
|
(let [enc (png/encoder 5 4 2)
|
|
a (ras 5 4)
|
|
b (raster/clear! (raster/make 5 4) 9)
|
|
hex #(apply str (map (fn [i] (.toString (aget % i) 16)) (range (.-length %))))]
|
|
(-> (.then (try! #(enc a ramp))
|
|
(fn [first-a]
|
|
(-> (try! #(enc b ramp))
|
|
(.then (fn [_] (try! #(enc a ramp))))
|
|
(.then (fn [second-a]
|
|
(is (= (hex first-a) (hex second-a))
|
|
"the same raster encoded twice, around another frame")
|
|
(done))))))
|
|
(.catch (fn [e] (is false (str "threw: " e)) (done)))))))
|