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

Merge master drawing tools with tracing layers

Browse source
This commit is contained in:
Olive Vaughn 2026-10-04 00:05:16 -04:00
commit f4dd047642
27 changed files with 2025 additions and 306 deletions
Download patch file Download diff file Expand all files Collapse all files

63
frontend/test/arthur/domain/cut_test.cljs Normal file
View file

@ -0,0 +1,63 @@
(ns arthur.domain.cut-test
(:require [cljs.test :refer [deftest is]]
[arthur.domain.channel :as channel]
[arthur.domain.clip :as clip]
[arthur.domain.cut :as cut]
[arthur.domain.paint :as paint]
[arthur.domain.raster :as r]))
(def square [10 10 50 10 50 50 10 50])
(defn- ink [ring]
(let [b (:buf (r/fill-poly-buf! (r/make 60 60) ring (quot (count ring) 2) 1))]
(fn [x y] (aget b (+ x (* y 60))))))
(deftest a-cut-off-the-side-keeps-the-rest-with-the-cut-edge-as-its-points
(let [[left & more] (cut/cut square [[[40 0 60 0 60 60 40 60]]])]
(is (empty? more))
(is (= 1 ((ink left) 20 30)))
(is (= 0 ((ink left) 45 30)))
(is (some #{40} (take-nth 2 left)) "the cut edge is the shape's own points")))
(deftest a-cut-through-the-middle-leaves-two-pieces-biggest-first
(let [pieces (cut/cut square [[[25 0 30 0 30 60 25 60]]])]
(is (= 2 (count pieces)))
(is (= 1 ((ink (first pieces)) 40 30)) "the right side is the bigger")
(is (= 1 ((ink (second pieces)) 15 30)))))
(deftest a-cut-inside-leaves-a-hole-in-one-ring
(let [[ring & more] (cut/cut square [[[25 25 35 25 35 35 25 35]]])]
(is (empty? more))
(is (= 0 ((ink ring) 30 30)))
(is (= 1 ((ink ring) 15 30)))))
(deftest a-cut-that-misses-is-nil-and-one-that-takes-everything-is-empty
(is (nil? (cut/cut square [[[0 0 5 0 5 5 0 5]]])))
(is (= [] (cut/cut square [[[0 0 60 0 60 60 0 60]]]))))
(deftest a-ring-with-a-bridged-hole-cuts-like-the-shape-it-draws
(let [holed (first (cut/cut square [[[25 25 35 25 35 35 25 35]]]))
[ring] (cut/cut holed [[[0 0 20 0 20 60 0 60]]])]
(is (= 0 ((ink ring) 30 30)) "the hole is still a hole")
(is (= 0 ((ink ring) 15 30)))
(is (= 1 ((ink ring) 45 30)))))
(deftest erasing-keeps-the-big-piece-on-the-shape-and-makes-the-rest-new
(let [clip (-> (clip/blank) (paint/new-shape :main :s 0 square 3))
out (cut/erase clip nil :main 0 [[:s]] [[[25 0 30 0 30 60 25 60]]] [:t :u])
nodes (get-in out [:symbols :main :nodes])
pts #(channel/value-at (get-in nodes [% :channels paint/geometry]) 0 nil)]
(is (= #{:s :t} (set (keys nodes))))
(is (= 1 ((ink (pts :s)) 40 30)))
(is (= 1 ((ink (pts :t)) 15 30)))
(is (= 3 (channel/value-at (get-in nodes [:t :channels [:style :color]]) 0 nil)))
(is (= {} (get-in (cut/erase clip nil :main 0 [[:s]] [[[0 0 60 0 60 60 0 60]]] [])
[:symbols :main :nodes]))
"cut away entirely, it is gone")))
(deftest erasing-between-keys-keys-the-frame-and-leaves-the-others
(let [clip (-> (clip/blank) (paint/new-shape :main :s 0 square 3) (paint/add-key :main :s 10))
out (cut/erase clip nil :main 5 [[:s]] [[[40 0 60 0 60 60 40 60]]] [])
ks (get-in out [:symbols :main :nodes :s :channels paint/geometry :keys])]
(is (= #{0 5 10} (set (keys ks))))
(is (= square (ks 0) (ks 10)))))

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

@ -7,6 +7,8 @@
[arthur.domain.nest :as nest]
[arthur.domain.node :as node]
[arthur.domain.paint :as paint]
[arthur.domain.pick :as pick]
[arthur.domain.raster :as raster]
[arthur.domain.pose :as pose]
[arthur.domain.palette :as pal]
[arthur.domain.symbol :as symbol]))
@ -480,3 +482,64 @@
(is (= [128 128 128]
(nth (pal/effective-ramp context (clip/active-palette resolve))
(pal/render-index context day 1))))))
(deftest a-knockout-makes-a-hole-in-its-own-symbol-only
(let [sq (fn [x0 y0 x1 y1] [x0 y0 x1 y0 x1 y1 x0 y1])
document
(-> (clip/blank)
(assoc-in [:symbols :lens] {:id :lens :frames 4 :nodes {}})
(paint/new-shape :main :under 0 (sq 0 0 40 20) 4)
(paint/new-shape :lens :frame 0 (sq 0 0 40 20) 8)
(paint/new-shape :lens :glass 0 (sq 10 5 20 15) :clear)
(assoc-in [:symbols :main :nodes :glasses]
{:id :glasses :kind :instance :source {:symbol :lens} :z "zz" :span [0 4]}))
ops (vec ((clip/resolver document :main nil (pal/compile document) nil) 0))
ras (raster/draw-ops! (raster/clear! (raster/make 320 200) 0) ops)
at (fn [x y] (aget (:buf ras) (+ x (* y 320))))
colour (fn [path] (:color (first (filter #(= path (:node %)) ops))))]
(is (= [:begin :poly :poly :end]
(mapv :kind (filter #(and (vector? (:node %)) (= :glasses (first (:node %)))) ops))))
(is (= (colour :under) (at 15 10)) "the glass shows what is under the glasses")
(is (= (colour [:glasses :frame]) (at 5 10)) "and the frame is still there round it")
(is (not= (at 15 10) (at 5 10)))
(is (= [:under] (pick/hit ops [15 10])) "a click in the glass is a click on what shows")
(is (= [:glasses :frame] (pick/hit ops [5 10])))))
(deftest an-op-goes-into-the-layer-of-the-symbol-it-is-for
(let [a {:kind :poly :node :a} b {:kind :poly :node [:g :b]} c {:kind :poly :node [:g :c]}
k {:kind :mask :knock -1}]
(is (= [a {:kind :begin :node [:g]} b c k {:kind :end :node [:g]}]
(clip/in-layer [a b c] [:g] k)) "a layer is made round what it drew")
(is (= [a {:kind :begin :node [:g]} b k {:kind :end :node [:g]} c]
(clip/in-layer [a {:kind :begin :node [:g]} b {:kind :end :node [:g]} c] [:g] k))
"an existing one is used")
(is (= [{:kind :begin :node []} a b k {:kind :end :node []}]
(clip/in-layer [a b] [] k)) "the open symbol is every op")
(is (= [a] (clip/in-layer [a] [:nothing] k)))))
(deftest a-preview-goes-on-top-of-its-own-symbol-only
(let [a {:kind :poly :node :a} b {:kind :poly :node [:g :b]} c {:kind :poly :node :c}
p {:kind :poly :preview true}]
(is (= [a b p c] (clip/atop [a b c] [:g] p)) "under what is above the symbol")
(is (= [a b c p] (clip/atop [a b c] [] p)) "the open symbol is on top of everything")
(is (= [a b c p] (clip/atop [a b c] [:empty] p)))))
(deftest a-remap-shape-lights-what-is-under-it-and-nothing-else
;; A flashlight: a circle that draws nothing of its own, and draws what is
;; already under it in other slots of the palette.
(let [sq (fn [x0 y0 x1 y1] [x0 y0 x1 y0 x1 y1 x0 y1])
document (-> (clip/blank)
(paint/new-shape :main :wall 0 (sq 0 0 40 20) 2)
(paint/new-shape :main :door 0 (sq 10 0 20 20) 3)
(paint/new-shape :main :beam 0 (sq 5 5 15 15) [:remap {2 5}])
(assoc-in [:symbols :main :nodes :wall :z] "a")
(assoc-in [:symbols :main :nodes :door :z] "b")
(assoc-in [:symbols :main :nodes :beam :z] "c"))
context (pal/compile document)
ops (vec ((clip/resolver document :main nil context nil) 0))
ras (raster/draw-ops! (raster/clear! (raster/make 320 200) 0) ops)
at (fn [x y] (aget (:buf ras) (+ x (* y 320))))
slot #(pal/render-index context (pal/default-palette-id document) %)]
(is (= (slot 5) (at 7 10)) "the wall under the beam is lit")
(is (= (slot 3) (at 12 10)) "the door under it is a slot the map leaves alone")
(is (= (slot 2) (at 30 10)) "and the wall outside it is as it was")
(is (= [:wall] (pick/hit ops [7 10])) "a click goes through the light")))

98
frontend/test/arthur/domain/outline_test.cljs Normal file
View file

@ -0,0 +1,98 @@
(ns arthur.domain.outline-test
(:require [cljs.test :refer [deftest is]]
[arthur.domain.outline :as outline]
[arthur.domain.raster :as r]))
(defn- covered [{:keys [buf]}] (count (filter #(= 1 %) (array-seq buf))))
(deftest a-traced-ring-fills-back-to-exactly-the-mask
(let [m (outline/stamp! (outline/mask 40 30) [8 8] [30 20] 6)
[ring & more] (outline/rings m)
back (r/fill-poly-buf! (r/make 40 30) ring (quot (count ring) 2) 1)]
(is (empty? more) "one stroke is one piece")
(is (= (vec (array-seq (:buf m))) (vec (array-seq (:buf back)))))))
(deftest a-single-pixel-is-a-square
(let [m (outline/mask 5 5)]
(aset (:buf m) 12 1)
(is (= [[2 2 3 2 3 3 2 3]] (outline/rings m 0)))))
(deftest pieces-are-traced-apart-biggest-first
(let [m (-> (outline/mask 40 20)
(outline/stamp! [5 10] [5 10] 4)
(outline/stamp! [20 10] [34 10] 6))]
(is (= 2 (count (outline/rings m))))
(is (< 8 (covered m)))
(is (< 15 (apply min (take-nth 2 (first (outline/rings m))))) "the long one first")))
(deftest a-fit-keeps-the-corners-and-straightens-the-stairs
(let [block (let [m (outline/mask 60 60)]
(doseq [y (range 10 40) x (range 10 50)] (aset (:buf m) (+ x (* y 60)) 1))
(first (outline/rings m)))
stairs (let [m (outline/mask 60 60)]
(doseq [y (range 5 55) x (range 5 (inc y))] (aset (:buf m) (+ x (* y 60)) 1))
(first (outline/rings m)))]
(is (= 8 (count (outline/fit block 1))) "a rectangle is its four corners")
(is (= 6 (count (outline/fit stairs 1))) "a pixel staircase is one diagonal: a triangle")
(is (< 6 (count (outline/fit stairs 0.25))) "unless asked to fit closer than the steps")))
(deftest a-loop-keeps-its-hole-in-one-ring
;; A ring of brush round a gap: one piece, one hole, and the one polygon it
;; makes fills back to the ring and leaves the gap empty.
(let [m (reduce (fn [m a]
(let [p #(vector (+ 30 (* 15 (js/Math.cos %))) (+ 30 (* 15 (js/Math.sin %))))]
(outline/stamp! m (p a) (p (+ a 0.3)) 5)))
(outline/mask 60 60) (range 0 6.6 0.3))
[piece & more] (outline/pieces m)
fill (fn [ring] (:buf (r/fill-poly-buf! (r/make 60 60) ring (quot (count ring) 2) 1)))
middle (+ 30 (* 30 60))]
(is (empty? more))
(is (= 1 (count (:holes piece))))
(is (= (vec (array-seq (:buf m))) (vec (array-seq (fill (outline/polygon piece 0.01)))))
"unsimplified, the bridged ring is the stroke exactly")
(is (zero? (aget (fill (outline/polygon piece 0.01)) middle)) "the middle is a hole")
(is (zero? (aget (fill (outline/polygon piece 8)) middle)) "and simplified, still a hole")))
(deftest overlapping-strokes-leave-no-slivers-and-nothing-crosses
;; A scribble back and forth over itself: the gaps between passes are not
;; holes anyone meant, and the one ring it makes fills back to the scribble
;; without a cut through it.
(let [m (reduce (fn [m i] (outline/stamp! m [10 (+ 10 (* 3 i))] [70 (+ 12 (* 3 i))] 5))
(outline/mask 80 60) (range 10))
[piece] (outline/pieces m)
ring (outline/polygon piece 1)
back (:buf (r/fill-poly-buf! (r/make 80 60) ring (quot (count ring) 2) 1))
miss (count (filter true? (map not= (array-seq (:buf m)) (array-seq back))))]
(is (< miss 80) (str miss " pixels differ — within a pixel of the edge, not a cut"))
(is (every? #(< (count %) 40) (outline/rings-of piece 1)) "and every ring is simple")))
(deftest a-gap-open-to-the-outside-is-not-a-hole
(let [m (-> (outline/mask 40 40)
(outline/stamp! [5 5] [30 5] 4)
(outline/stamp! [30 5] [30 30] 4)
(outline/stamp! [30 30] [5 30] 4))]
(is (= [] (:holes (first (outline/pieces m)))))))
(deftest a-small-hole-is-a-few-points-not-its-staircase
(let [m (outline/mask 60 60)]
(doseq [y (range 10 50) x (range 10 50)
:when (not (and (< 25 x 34) (< 25 y 34)))]
(aset (:buf m) (+ x (* y 60)) 1))
(let [[outer hole] (outline/rings-of (first (outline/pieces m)) 1)]
(is (= 8 (count outer)))
(is (= 8 (count hole)) "an 8×8 hole is its four corners"))))
(deftest a-hole-whose-fit-would-cross-the-outside-is-clipped-to-it
;; A wedge-shaped gap reaching to within a pixel of the outside: fitted on its
;; own, its edge can cross the outside's. It stays a hole, inside the body.
(let [m (outline/mask 60 60)]
(doseq [y (range 10 50) x (range 10 50)
:when (not (and (< 12 x 47) (< 12 y (- 47 (quot (- x 12) 3)))))]
(aset (:buf m) (+ x (* y 60)) 1))
(let [rs (outline/rings-of (first (outline/pieces m)) 3)
ring (outline/join rs)
back (:buf (r/fill-poly-buf! (r/make 60 60) ring (quot (count ring) 2) 1))]
(is (< 1 (count rs)) "the hole is kept")
(is (zero? (aget back (+ 25 (* 20 60)))) "and is a hole")
(is (every? #(< (count %) 30) rs) "and simple")
(is (zero? (aget back (+ 5 (* 5 60)))) "and nothing outside the body is filled"))))

11
frontend/test/arthur/domain/paint_test.cljs
View file

@ -33,3 +33,14 @@
(is (some #(= :paint-test (:node %))
(symbol/eval-frame (get-in c2 [:symbols :main]) 3 nil pal/index-of nil)))
(is (= mixed-clip (leaf/clip :c1 (leaf/leaves :c1 mixed-clip))))))
(deftest a-point-is-added-and-taken-away-on-every-key
(let [c0 (-> (paint/new-shape demo/clip :main :p 0 [0 0 10 0 10 10] :brow)
(paint/add-key :main :p 6)
(paint/set-vertex :main :p 6 1 [20 0]))
c1 (paint/insert-vertex c0 :main :p 0 0.5)
ks #(get-in % [:symbols :main :nodes :p :channels paint/geometry :keys])]
(is (= {0 [0 0 5 0 10 0 10 10] 6 [0 0 10 0 20 0 10 10]} (ks c1))
"half way along the same edge of each key")
(is (= (ks c0) (ks (paint/delete-vertex c1 :main :p 1))))
(is (= (ks c0) (ks (paint/delete-vertex c0 :main :p 0))) "a triangle keeps its three")))

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

@ -219,3 +219,34 @@
(let [dest (js/Uint8ClampedArray. (* 23 17 4))]
(is (= (naive ras pal/rgb 1)
(vec (array-seq (:data (r/->rgba ras pal/rgb 1 dest))))))))))
(defn- sq [x0 y0 x1 y1] [x0 y0 x1 y0 x1 y1 x0 y1])
(deftest a-knockout-clears-its-own-layer-and-nothing-under-it
(let [ras (-> (r/make 20 10) (r/clear! 0)
(r/draw-ops! [{:kind :poly :pts (sq 0 0 20 10) :n 4 :color 1}
{:kind :begin}
{:kind :poly :pts (sq 0 0 10 10) :n 4 :color 2}
{:kind :poly :pts (sq 10 0 20 10) :n 4 :color 3}
{:kind :poly :pts (sq 5 0 15 10) :n 4 :color 0 :knock -1}
{:kind :end}]))]
(is (= 50 (count-index ras 2)) "0..5 of the left half is left")
(is (= 50 (count-index ras 3)) "15..20 of the right half is left")
(is (= 100 (count-index ras 1)) "the hole shows what was under the layer")))
(deftest a-knockout-of-one-colour-leaves-the-others
(let [ras (-> (r/make 20 10) (r/clear! 0)
(r/draw-ops! [{:kind :begin}
{:kind :poly :pts (sq 0 0 10 10) :n 4 :color 2}
{:kind :poly :pts (sq 10 0 20 10) :n 4 :color 3}
{:kind :poly :pts (sq 0 0 20 10) :n 4 :color 0 :knock 3}
{:kind :end}]))]
(is (= 100 (count-index ras 2)))
(is (zero? (count-index ras 3)))))
(deftest a-mask-op-paints-the-pixels-it-holds
(let [m (js/Uint8Array. 200)]
(aset m 3 1) (aset m 150 1)
(is (= 2 (count-index (-> (r/make 20 10) (r/clear! 0)
(r/draw-ops! [{:kind :mask :mask m :color 4}]))
4)))))

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

@ -335,7 +335,7 @@
:playback {:frame 6}}
after (ui/beginning-polygon db)
saved (:clip (store/entry (:clip/current after)))]
(is (= :polygon (get-in after [:ui :tool])))
(is (= [] (get-in after [:ui :draft])) "a draft is begun")
(is (= {} (get-in saved [:symbols :main :nodes])))
(is (nil? (get-in saved [:symbols :main :display])))
(is (nil? (get-in (store/entry (:clip/current after)) [:history :done])))))
@ -353,7 +353,7 @@
(is (not= :a cel-id) "the occupied cel is not reused")
(is (= [1 2] (node/placed-span (get-in saved [:symbols sid :nodes cel-id]))))
(is (= 1 (clip/frames saved (node/source (get-in saved [:symbols sid :nodes cel-id])))))
(is (= :polygon (get-in after [:ui :tool])))))
(is (= [] (get-in after [:ui :draft])))))
(deftest sequence-commands-use-isolated-history-transactions
(let [doc (fixture/document)
@ -455,7 +455,7 @@
(is (= :drawing-a sid) "the shape went into the drawing the selected clip places")
(is (= [:a shape-id] path))
(is (empty? (get-in after [:ui :expanded])))
(is (nil? (get-in after [:ui :tool]))))))
(is (empty? (get-in after [:ui :draft])) "the pen stays the tool, with nothing drafted"))))
(deftest a-clip-made-for-a-drawing-is-selected-in-the-symbol-it-lives-in
;; The clip `beginning-polygon` materializes lives in the symbol the LANE