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

Add remap ink, eraser cuts, and improved brush geometry

Browse source
This commit is contained in:
Olive Vaughn 2026-10-04 00:00:09 -04:00
parent 1f0b4d9918
commit 353cb6e050
19 changed files with 747 additions and 224 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)))))

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

@ -522,3 +522,24 @@
(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")))

56
frontend/test/arthur/domain/outline_test.cljs
View file

@ -25,11 +25,16 @@
(is (< 8 (covered m)))
(is (< 15 (apply min (take-nth 2 (first (outline/rings m))))) "the long one first")))
(deftest simplify-keeps-exactly-the-count-asked-for
(let [ring (first (outline/rings (outline/stamp! (outline/mask 60 60) [30 30] [30 30] 40)))]
(is (= 24 (count (outline/simplify ring 12))))
(is (= 6 (count (outline/simplify ring 1))) "never fewer than three points")
(is (= ring (outline/simplify ring 10000)))))
(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
@ -48,11 +53,18 @@
(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 points-go-by-length
(let [dab (first (outline/pieces (outline/stamp! (outline/mask 80 40) [10 20] [10 20] 8)))
long (first (outline/pieces (outline/stamp! (outline/mask 80 40) [10 20] [70 20] 8)))]
(is (< (count (outline/polygon dab 6)) (count (outline/polygon long 6))))
(is (= 6 (count (outline/polygon dab 1000))) "never fewer than three")))
(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)
@ -60,3 +72,27 @@
(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"))))