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

26
frontend/package-lock.json generated
View file

@ -9,6 +9,7 @@
"version": "0.0.1",
"dependencies": {
"@mediapipe/tasks-vision": "1.0.1",
"polygon-clipping": "^0.15.7",
"react": "^18.3.1",
"react-dom": "^18.3.1"
},
@ -1015,6 +1016,16 @@
"node": ">= 0.10"
}
},
"node_modules/polygon-clipping": {
"version": "0.15.7",
"resolved": "https://registry.npmjs.org/polygon-clipping/-/polygon-clipping-0.15.7.tgz",
"integrity": "sha512-nhfdr83ECBg6xtqOAJab1tbksbBAOMUltN60bU+llHVOL0e5Onm1WpAXXWXVB39L8AJFssoIhEVuy/S90MmotA==",
"license": "MIT",
"dependencies": {
"robust-predicates": "^3.0.2",
"splaytree": "^3.1.0"
}
},
"node_modules/possible-typed-array-names": {
"version": "1.1.0",
"resolved": "https://registry.npmjs.org/possible-typed-array-names/-/possible-typed-array-names-1.1.0.tgz",
@ -1216,6 +1227,12 @@
"node": ">= 0.8"
}
},
"node_modules/robust-predicates": {
"version": "3.0.3",
"resolved": "https://registry.npmjs.org/robust-predicates/-/robust-predicates-3.0.3.tgz",
"integrity": "sha512-NS3levdsRIUOmiJ8FZWCP7LG3QpJyrs/TE0Zpf1yvZu8cAJJ6QMW92H1c7kWpdIHo8RvmLxN/o2JXTKHp74lUA==",
"license": "Unlicense"
},
"node_modules/safe-buffer": {
"version": "5.2.1",
"resolved": "https://registry.npmjs.org/safe-buffer/-/safe-buffer-5.2.1.tgz",
@ -1416,6 +1433,15 @@
"source-map": "^0.5.6"
}
},
"node_modules/splaytree": {
"version": "3.2.3",
"resolved": "https://registry.npmjs.org/splaytree/-/splaytree-3.2.3.tgz",
"integrity": "sha512-7OXrNWzy6CK+r7Ch9OLPBDTKfB6XlWHjX4P0RU5B3IgFuWPeYN0XtRtlexGRjgbQxpfaUve6jTAwBGWuGntz/w==",
"license": "MIT",
"engines": {
"node": ">=18.20 || >=20"
}
},
"node_modules/stream-browserify": {
"version": "2.0.2",
"resolved": "https://registry.npmjs.org/stream-browserify/-/stream-browserify-2.0.2.tgz",

1
frontend/package.json
View file

@ -10,6 +10,7 @@
},
"dependencies": {
"@mediapipe/tasks-vision": "1.0.1",
"polygon-clipping": "^0.15.7",
"react": "^18.3.1",
"react-dom": "^18.3.1"
},

9
frontend/src/arthur/domain/clip.cljs
View file

@ -434,8 +434,10 @@
(placed-frame clip sid n local))
frame (:frame shown)]
(if (and frame (<= 0 frame) (< frame length))
(do (vswap! entered assoc id (:symbol shown))
(map #(transform-op % m [id])
(let [override (when (and context? (:palette n))
(selection-at n frame nil))]
(vswap! entered assoc id (:symbol shown))
(map #(transform-op % m [id])
((get children [id (:symbol shown)])
frame
;; The slot's interval crosses the
@ -452,8 +454,7 @@
(placed-frame clip sid n prior)))
(dec frame))
@active
(when (and context? (:palette n))
(selection-at n frame nil)))))
override)))
[]))
(when-let [op (get by-id id)] [op]))))
ids))

74
frontend/src/arthur/domain/cut.cljs Normal file
View file

@ -0,0 +1,74 @@
(ns arthur.domain.cut
"The eraser's cut: a shape's ring with a stroke taken out of it.
Illustrator's and Flash's eraser, not a raster one: what is left is the
SHAPE, with the cut edge made of its own points — points the pen moves, keys
and tweens like any others. A cut through the middle leaves two pieces, and
a cut inside it leaves a hole, which is bridged into the one ring as a brush
stroke's is (see `outline`).
In stage pixels, on both sides: the preview cuts the rings it is about to
draw, and the saved cut cuts the same rings and takes the answer back into
the shape's own coordinates — one function, so the preview is the result."
(:require ["polygon-clipping" :as clipping]
[arthur.domain.channel :as channel]
[arthur.domain.nest :as nest]
[arthur.domain.node :as node]
[arthur.domain.outline :as outline]
[arthur.domain.paint :as paint]))
(defn- area [ring]
(let [ps (vec (partition 2 ring)) n (count ps)]
(js/Math.abs (/ (reduce + (map (fn [i] (let [[ax ay] (ps i) [bx by] (ps (mod (inc i) n))]
(- (* ax by) (* bx ay))))
(range n)))
2))))
(defn cut
"Ring `ring` with `cutters` — each `[outer & holes]` — taken out of it: one
ring per piece left, biggest first, an empty vector when nothing is left, or
nil when the cut does not touch it."
[ring cutters]
(let [shape #js [(outline/->js ring)]
knife (into-array (map #(into-array (map outline/->js %)) cutters))]
(when (seq (array-seq (clipping/intersection shape knife)))
(->> (array-seq (clipping/difference shape knife))
(map (fn [^js poly] (mapv outline/->ring (array-seq poly))))
(sort-by (comp - area first))
(mapv outline/join)))))
(defn- through [m pts]
(let [out (js/Float64Array. 2)]
(into [] (mapcat (fn [[x y]] (node/apply-pt! out 0 m x y) [(aget out 0) (aget out 1)]))
(partition 2 pts))))
(defn erase
"`clip` with `cutters`, in the stage pixels of symbol `open` at frame `f`,
cut out of each shape at row path in `paths`, on the frame each is showing.
The shape keeps the biggest piece, on a key at that frame — made there if
the frame had none, so the keys either side keep their points. Every other
piece is a new shape of the same colour, its id the next of `ids`. A shape
cut away entirely is deleted."
[clip store open f paths cutters ids]
(first
(reduce
(fn [[clip ids] path]
(let [{:keys [sid id frame world]} (nest/placement clip store open path f)
n (get-in clip [:symbols sid :nodes id])
geom (get-in n [:channels paint/geometry])
inv (when world (node/invert world))
left (when (and inv geom)
(cut (through world (channel/value-at geom frame store)) cutters))]
(cond
(nil? left) [clip ids]
(empty? left) [(nest/delete-node clip sid id) ids]
:else
(let [[keep & more] (map #(through inv %) left)
colour (channel/value-at (get-in n [:channels [:style :color]]) frame store)
kept (-> (if (contains? (:keys geom) frame) clip (paint/add-key clip sid id frame))
(paint/set-points sid id frame keep))]
[(reduce (fn [c [nid pts]] (paint/new-shape c sid nid frame pts colour))
kept (map vector ids more))
(drop (count more) ids)]))))
[clip ids] paths)))

170
frontend/src/arthur/domain/outline.cljs
View file

@ -20,10 +20,15 @@
one. It is how earcut and the TrueType rasterisers take holes too.
`pieces` keeps the trace — outside and holes, at full resolution — so the
count of points can change after the stroke, and `polygon` is the one place
it is simplified and bridged: the preview and the saved shape are the same
function's output, so what is on screen while painting is what is kept."
(:require [arthur.domain.raster :as raster]))
fit can change after the stroke, and `polygon` is the one place it is fitted
and bridged: the preview and the saved shape are the same function's output,
so what is on screen while painting is what is kept.
FITTED TO A TOLERANCE, not cut to a count: every point of the traced edge is
within so many pixels of the polygon (Douglas-Peucker), so points go where
the shape bends and none are spent on a straight run."
(:require ["polygon-clipping" :as clipping]
[arthur.domain.raster :as raster]))
(defn mask [w h] {:w w :h h :buf (js/Uint8Array. (* w h))})
@ -149,51 +154,14 @@
([m] (rings m 2))
([m smallest] (mapv :outer (pieces m smallest))))
(defn simplify
"Ring `pts` cut down to `n` points, a closed ring of at least three:
Visvalingam's, which takes away whichever point makes the smallest triangle
with its neighbours until `n` are left — so the corners that carry the shape
are the last to go, and the count is exactly the one asked for.
Over typed arrays and a linked ring, because it runs on every pointer move of
a brush stroke: taking a point away changes only its two neighbours' areas."
[pts n]
(let [c (quot (count pts) 2)
n (max 3 n)]
(if (<= c n)
(vec pts)
(let [xs (js/Float64Array. c) ys (js/Float64Array. c)
prev (js/Int32Array. c) next (js/Int32Array. c)
area (js/Float64Array. c)
live (js/Uint8Array. c)
best (js/Int32Array. 1)
tri! (fn [k]
(let [a (aget prev k) d (aget next k)]
(aset area k (js/Math.abs (- (* (- (aget xs k) (aget xs a)) (- (aget ys d) (aget ys a)))
(* (- (aget xs d) (aget xs a)) (- (aget ys k) (aget ys a))))))))]
(dotimes [k c]
(aset xs k (nth pts (* 2 k))) (aset ys k (nth pts (inc (* 2 k))))
(aset prev k (mod (dec k) c)) (aset next k (mod (inc k) c))
(aset live k 1))
(dotimes [k c] (tri! k))
(dotimes [_ (- c n)]
(let [_ (aset best 0 -1)
_ (dotimes [k c]
(when (and (== 1 (aget live k))
(or (neg? (aget best 0)) (< (aget area k) (aget area (aget best 0)))))
(aset best 0 k)))
k (aget best 0)
a (aget prev k) d (aget next k)]
(aset live k 0)
(aset next a d) (aset prev d a)
(tri! a) (tri! d)))
(into [] (mapcat (fn [k] (when (== 1 (aget live k)) [(aget xs k) (aget ys k)]))) (range c))))))
(defn- perimeter [pts]
(defn- area
"The area inside ring `pts`, by the shoelace."
[pts]
(let [ps (vec (partition 2 pts)) n (count ps)]
(reduce + (map (fn [i] (let [[ax ay] (ps i) [bx by] (ps (mod (inc i) n))]
(js/Math.hypot (- bx ax) (- by ay))))
(range n)))))
(js/Math.abs (/ (reduce + (map (fn [i] (let [[ax ay] (ps i) [bx by] (ps (mod (inc i) n))]
(- (* ax by) (* bx ay))))
(range n)))
2))))
(defn- bridge
"Ring `outer` with `hole` joined into it: from the hole's leftmost point,
@ -224,12 +192,102 @@
(apply concat (subvec os (inc i)))))
outer)))
(defn- dp
"Douglas-Peucker over the open run of points `i`..`j` of `xs`/`ys`: the
indices kept so that no point between is further than `tol` from the line."
[^js xs ^js ys i j tol]
(let [ax (aget xs i) ay (aget ys i) bx (aget xs j) by (aget ys j)
dx (- bx ax) dy (- by ay) l (js/Math.hypot dx dy)
[k d] (reduce (fn [[_ best :as acc] k]
(let [px (- (aget xs k) ax) py (- (aget ys k) ay)
e (if (zero? l) (js/Math.hypot px py) (/ (js/Math.abs (- (* dx py) (* dy px))) l))]
(if (< best e) [k e] acc)))
[nil 0] (range (inc i) j))]
(if (and k (< tol d))
(into (dp xs ys i k tol) (rest (dp xs ys k j tol)))
[i j])))
(defn fit
"Ring `pts` with as few points as keep every point of it within `tol` pixels
of the result: Douglas-Peucker, closed by splitting at the point furthest from
the first. A pixel staircase within a pixel of a diagonal becomes the
diagonal, and a square corner stays — the points go where the shape bends."
[pts tol]
(let [c (quot (count pts) 2)]
(if (<= c 3)
(vec pts)
(let [xs (js/Float64Array. (take-nth 2 pts)) ys (js/Float64Array. (take-nth 2 (rest pts)))
far (apply max-key #(js/Math.hypot (- (aget xs %) (aget xs 0)) (- (aget ys %) (aget ys 0)))
(range c))
xs2 (js/Float64Array. (inc c)) ys2 (js/Float64Array. (inc c))
_ (dotimes [k c] (aset xs2 k (aget xs k)) (aset ys2 k (aget ys k)))
_ (do (aset xs2 c (aget xs 0)) (aset ys2 c (aget ys 0)))
keep (into (dp xs2 ys2 0 far tol) (rest (butlast (dp xs2 ys2 far c tol))))]
(if (< (count keep) 3)
(vec pts)
(into [] (mapcat (fn [k] [(aget xs k) (aget ys k)])) keep))))))
(defn- crosses?
"Does any edge of ring `a` cross any edge of ring `b`?"
[a b]
(let [edges (fn [r] (let [ps (vec (partition 2 r)) n (count ps)]
(map (fn [i] [(ps i) (ps (mod (inc i) n))]) (range n))))
side (fn [[ax ay] [bx by] [px py]] (- (* (- bx ax) (- py ay)) (* (- by ay) (- px ax))))]
(some (fn [[p q]]
(some (fn [[r s]]
(and (neg? (* (side p q r) (side p q s)))
(neg? (* (side r s p) (side r s q)))))
(edges b)))
(edges a))))
(defn- perimeter [pts]
(let [ps (vec (partition 2 pts)) n (count ps)]
(reduce + (map (fn [i] (let [[ax ay] (ps i) [bx by] (ps (mod (inc i) n))]
(js/Math.hypot (- bx ax) (- by ay))))
(range n)))))
(defn ->js
"Flat ring `ring` as `polygon-clipping` takes one."
[ring]
(into-array (map into-array (partition 2 ring))))
(defn ->ring
"A ring back from `polygon-clipping`, flat, without the point it repeats to
close."
[^js r]
(into [] (mapcat identity) (butlast (map vec (array-seq r)))))
(defn rings-of
"Piece `p` of `pieces` fitted to within `tol` pixels, outside first, holes
after.
EVERY HOLE IS KEPT, and kept simple: fitted like the outside, then clipped to
the inside of it and clear of the holes before it. Fitting each ring on its
own can push a hole's edge across the outside's, and a crossing is what makes
the even-odd fill cut through the body; clipping takes exactly that part off
and leaves the few points the fit chose. Fitting closer until nothing crossed
was tried, and spent hundreds of points on what is plainly a straight line."
[{:keys [outer holes]} tol]
(let [outer (fit outer tol)]
(reduce (fn [rs hole]
(let [h (fit hole tol)]
(if (not-any? #(crosses? h %) rs)
(conj rs h)
(let [inside (clipping/intersection #js [(->js h)] #js [(->js outer)])
clear (if (next rs)
(clipping/difference inside (into-array (map #(array (->js %)) (rest rs))))
inside)]
(into rs (comp (map #(->ring (aget % 0))) (filter #(< 2 (area %))))
(array-seq clear))))))
[outer]
(sort-by (comp - area) holes))))
(defn join
"Rings `[outer & holes]` as one ring, each hole bridged in, leftmost first."
[[outer & holes]]
(reduce bridge outer (sort-by #(apply min (take-nth 2 %)) holes)))
(defn polygon
"Piece `p` of `pieces` as one ring, with a point about every `spacing` pixels
of its outline — so a long stroke gets more points than a dab, and a hole gets
its own share — and the holes bridged in."
[{:keys [outer holes]} spacing]
(let [share #(max 3 (js/Math.round (/ (perimeter %) (max 0.01 spacing))))]
(reduce bridge (simplify outer (share outer))
(sort-by #(apply min (take-nth 2 %))
(map #(simplify % (share %)) holes)))))
"Piece `p` of `pieces` as the one ring a shape is made of. See `rings-of`."
[p tol]
(join (rings-of p tol)))

10
frontend/src/arthur/domain/pick.cljs
View file

@ -49,9 +49,10 @@
(and (<= (js/Math.abs (- x cx)) h) (<= (js/Math.abs (- y cy)) h)))
false))
(defn- op-bounds [{:keys [kind pts n cx cy r size knock]}]
;; A knockout draws nothing, so a marquee does not catch it.
(case (when-not knock kind)
(defn- op-bounds [{:keys [kind pts n cx cy r size knock lut]}]
;; A knockout or a remap draws nothing of its own, so a marquee does not
;; catch it.
(case (when-not (or knock lut) kind)
:poly (reduce (fn [b i]
(let [x (aget pts (* 2 i)) y (aget pts (inc (* 2 i)))]
(if b (let [[x0 y0 x1 y1] b]
@ -86,7 +87,8 @@
[ops [x y]]
(:op (reduce (fn [holes op]
(cond
(not (on? op x y)) holes
;; A remap is light on what is under it, not a thing.
(or (:lut op) (not (on? op x y))) holes
(:knock op) (conj holes [(pop (path-of op)) (:knock op)])
(some (fn [[in k]] (and (prefix? in (path-of op))
(or (neg? k) (== k (:color op)))))

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

@ -34,15 +34,22 @@
;; only where it is covered. The main raster has no `:cov` and is always
;; covered.
;;
;; `knock` is nil for an ordinary fill, -1 for a knockout of every colour, and
;; an index for a knockout of that colour only.
;; THE INK is how a shape marks the pixels it covers, and there are three, as
;; Deluxe Paint and Animator Pro had inks:
;;
;; nil an ordinary fill: write the shape's index
;; a number a knockout: clear coverage — of every colour at -1, or of
;; that index only
;; a Uint8Array a REMAP, index -> index: what is already there is drawn
;; in another slot. A flashlight is a circle of this.
(defn- plot! [^js buf cov o index knock]
(if (nil? knock)
(do (aset buf o index)
(when cov (aset cov o 1)))
(when (and cov (or (neg? knock) (== (aget buf o) knock)))
(aset cov o 0))))
(defn- plot! [^js buf cov o index ink]
(cond
(nil? ink) (do (aset buf o index)
(when cov (aset cov o 1)))
(number? ink) (when (and cov (or (neg? ink) (== (aget buf o) ink)))
(aset cov o 0))
:else (aset buf o (aget ink (aget buf o)))))
(defn- shows?
"Does pixel `o` hold `over`? A stencil only matches what is really there, so
@ -75,9 +82,9 @@
allocation is the only thing that will make this stutter.
`pts` may be a CLJS vector or any typed array; scanline crossings are collected
into a plain JS array and sorted in place. `knock` is as `plot!`'s."
into a plain JS array and sorted in place. `ink` is as `plot!`'s."
([r pts n index] (fill-poly-buf! r pts n index nil))
([{:keys [w h buf cov] :as r} pts n index knock]
([{:keys [w h buf cov] :as r} pts n index ink]
(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)))))
@ -119,7 +126,7 @@
x-to (min (dec w) (js/Math.floor (- xb 0.5)))
row (* y w)]
(dotimes [dx (inc (- x-to x-from))]
(plot! buf cov (+ row x-from dx) index knock)))))))))
(plot! buf cov (+ row x-from dx) index ink)))))))))
r))
(defn fill-poly!
@ -142,7 +149,7 @@
clamp that would flatten the performance at the extremes."
([r cx cy rad index] (fill-disc! r cx cy rad index nil nil))
([r cx cy rad index over] (fill-disc! r cx cy rad index over nil))
([{:keys [w h buf cov] :as r} cx cy rad index over knock]
([{:keys [w h buf cov] :as r} cx cy rad index over ink]
(let [rr (* rad rad)
y0 (max 0 (js/Math.floor (- cy rad)))
y1 (min (dec h) (js/Math.ceil (+ cy rad)))
@ -157,7 +164,7 @@
(when (<= (+ (* dx dx) (* dy dy)) rr)
(let [o (+ (* y w) x)]
(when (shows? buf cov o over)
(plot! buf cov o index knock)))))))
(plot! buf cov o index ink)))))))
r)))
(defn fill-rect!
@ -176,7 +183,7 @@
breathing."
([r cx cy size index] (fill-rect! r cx cy size index nil nil))
([r cx cy size index over] (fill-rect! r cx cy size index over nil))
([{:keys [w h buf cov] :as r} cx cy size index over knock]
([{:keys [w h buf cov] :as r} cx cy size index over ink]
(let [size (js/Math.round size)]
(when (>= size 1)
(let [x0 (js/Math.round (- cx (/ size 2)))
@ -187,7 +194,7 @@
(dotimes [ix (- xb xa)]
(let [o (+ (* (+ ya iy) w) xa ix)]
(when (shows? buf cov o over)
(plot! buf cov o index knock))))))))
(plot! buf cov o index ink))))))))
r))
(def ^:private little-endian?
@ -269,10 +276,10 @@
(defn- fill-mask!
"Every pixel set in `mask`, a byte per stage pixel: a brush stroke as it is
being painted, before it is a polygon."
[{:keys [buf cov] :as r} ^js mask index knock]
[{:keys [buf cov] :as r} ^js mask index ink]
(dotimes [o (.-length mask)]
(when (== 1 (aget mask o))
(plot! buf cov o index knock)))
(plot! buf cov o index ink)))
r)
;; One layer per depth of nesting, reused from frame to frame, as the resolver
@ -297,11 +304,12 @@
here indistinguishable from each other, which is the point.
`:begin` and `:end` bracket the ops of a symbol drawn into a layer of its own;
`:knock` on an op makes it a knockout. See `plot!`."
`:knock` on an op makes it a knockout and `:lut` a remap. See `plot!`."
[{:keys [w h] :as r} ops]
(reduce
(fn [stack {:keys [kind pts n color stencil cx cy size knock] :as op}]
(let [top (peek stack)]
(fn [stack {:keys [kind pts n color stencil cx cy size] :as op}]
(let [top (peek stack)
ink (or (:knock op) (:lut op))]
(case kind
:begin (let [l (layer-at (count stack) w h)]
(.fill (:cov l) 0)
@ -309,10 +317,10 @@
:end (if (< 1 (count stack))
(let [s (pop stack)] (composite! (peek s) top) s)
stack)
:poly (do (fill-poly-buf! top pts n color knock) stack)
:disc (do (fill-disc! top cx cy (:r op) color stencil knock) stack)
:rect (do (fill-rect! top cx cy size color stencil knock) stack)
:mask (do (fill-mask! top (:mask op) color knock) stack)
:poly (do (fill-poly-buf! top pts n color ink) stack)
:disc (do (fill-disc! top cx cy (:r op) color stencil ink) stack)
:rect (do (fill-rect! top cx cy size color stencil ink) stack)
:mask (do (fill-mask! top (:mask op) color ink) stack)
(throw (ex-info "draw op kind is not rasterisable" {:op (dissoc op :pts)})))))
[r] ops)
r)

23
frontend/src/arthur/domain/symbol.cljs
View file

@ -287,9 +287,25 @@
[c]
(or (= :clear c) (and (vector? c) (= :clear (first c)))))
(defn remap?
"Is colour `c` a REMAP: `[:remap {from to …}]`, slots of the palette in
scope? It draws nothing of its own; what is already under it is drawn in
other slots — a flashlight is a circle of this. See `raster/plot!`."
[c]
(and (vector? c) (= :remap (first c))))
(defn- knock-index [palette c]
(if (= :clear c) -1 (colour-index palette (second c))))
(defn lut
"Remap `[:remap m]` as a raster index -> index table in `palette`. Slots of
any other palette are left as they are."
[palette [_ m]]
(let [t (js/Uint8Array. 256)]
(dotimes [i 256] (aset t i i))
(doseq [[a b] m] (aset t (colour-index palette a) (colour-index palette b)))
t))
(defn knocks?
"Does any node in `nodes` knock out, on any frame? Such a symbol is drawn into
a layer of its own."
@ -424,9 +440,10 @@
;; `[:style :color]` to read.
(let [paint (fn [op]
(let [c (rd [:style :color])]
(if (knockout? c)
(assoc op :knock (knock-index palette c) :color 0)
(assoc op :color (colour-index palette c)))))]
(cond
(knockout? c) (assoc op :knock (knock-index palette c) :color 0)
(remap? c) (assoc op :lut (lut palette c) :color 0)
:else (assoc op :color (colour-index palette c)))))]
(case (:kind n)
:group nil
:instance nil

107
frontend/src/arthur/events/ui.cljs
View file

@ -20,6 +20,7 @@
[arthur.domain.channel :as ch]
[arthur.domain.clipboard :as clipboard]
[arthur.domain.correction :as correction]
[arthur.domain.cut :as cut]
[arthur.domain.creation :as creation]
[arthur.domain.gesture :as gesture]
[arthur.domain.nest :as nest]
@ -699,61 +700,79 @@
;; brush and eraser
;;
;; A stroke arrives as the pieces `domain/outline` traced off its mask, in stage
;; pixels, holes and all. Each becomes a shape with a point every `:spacing`
;; pixels of its outline — so a long stroke gets more than a dab. What it was
;; made from is kept in `[:ui :last]`, Blender's Adjust Last Operation, so the
;; spacing can be changed afterwards from the trace rather than from the points
;; already thrown away, until something else is done.
;; pixels, holes and all. Each becomes a shape fitted to within `:fit` pixels
;; of what was painted — points where it bends, none on a straight run. What
;; it was made from is kept in `[:ui :last]`, Blender's Adjust Last Operation,
;; so the fit can be changed afterwards from the trace rather than from the
;; points already thrown away, until something else is done.
(def default-spacing 6)
(def default-fit 1)
(defn- stroke-points [pieces spacing]
(mapv #(outline/polygon % spacing) pieces))
(defn- stroke-points [pieces fit]
(mapv #(outline/polygon % fit) pieces))
(rf/reg-event-db
::spacing
(fn [db [_ spacing]] (assoc-in db [:ui :spacing] (-> spacing (max 1) (min 40)))))
::fit
(fn [db [_ fit]] (assoc-in db [:ui :fit] (-> fit (max 0.5) (min 8)))))
(defn- saved [db] (:clip (store/entry (:clip/current db))))
(defn- fresh-ids [] (repeatedly #(keyword (str "paint-" (random-uuid)))))
(defn- erasing
"`db` with `pieces` cut out of the shapes at `paths`. See `cut/erase`."
[db before pieces fit paths ids]
(let [{st :store} (store/entry (:clip/current db))
cutters (mapv #(outline/rings-of % fit) pieces)]
(edit/transaction db (fn [_] (cut/erase before st (get-in db [:ui :open])
(editing-frame db before) paths cutters ids)))))
(rf/reg-event-db
::stroke
;; `down` and `colour` are the eraser's: the symbol the stroke began in, and
;; the knockout it makes there. The brush draws in the tone, into the creation
;; target, as the pen does.
(fn [db [_ {:keys [pieces down colour]}]]
(let [spacing (get-in db [:ui :spacing] default-spacing)
{:keys [refused clip sid frame] :as at} (when (seq pieces)
(landing-into db down (stroke-points pieces spacing)))
ids (vec (repeatedly (count pieces) #(keyword (str "paint-" (random-uuid)))))]
(cond
(empty? pieces) db
refused (update db :project merge {:status refused})
:else
(cond-> (-> db
(edit/transaction
(fn [_] (reduce (fn [c [id pts]]
(paint/new-shape c sid id frame pts
(or colour (get-in db [:ui :tone]))))
clip (map vector ids (:rings at)))))
(assoc-in [:ui :last] {:kind (if down :eraser :brush) :pieces pieces
:spacing spacing
:down (:down at) :sid sid :frame frame :ids ids}))
(nil? down) (selected [:node sid (peek ids) (conj (:down at) (peek ids))]))))))
;; The brush draws in the tone, into the creation target, as the pen does.
;; With `paths` it is the eraser's, and cuts the shapes they lead to.
(fn [db [_ {:keys [pieces paths]}]]
(let [fit (get-in db [:ui :fit] default-fit)
before (saved db)]
(if paths
(let [ids (vec (take 64 (fresh-ids)))
db (erasing db before pieces fit paths ids)]
(assoc-in db [:ui :last] {:kind :eraser :pieces pieces :paths paths :ids ids
:fit fit :before before :after (saved db)}))
(let [{:keys [refused clip sid frame] :as at} (when (seq pieces)
(landing-into db nil (stroke-points pieces fit)))
ids (vec (take (count pieces) (fresh-ids)))]
(cond
(empty? pieces) db
refused (update db :project merge {:status refused})
:else
(let [db (-> db
(edit/transaction
(fn [_] (reduce (fn [c [id pts]]
(paint/new-shape c sid id frame pts (get-in db [:ui :tone])))
clip (map vector ids (:rings at)))))
(selected [:node sid (peek ids) (conj (:down at) (peek ids))]))]
(assoc-in db [:ui :last] {:kind :brush :pieces pieces :fit fit
:down (:down at) :sid sid :frame frame :ids ids
:after (saved db)}))))))))
(rf/reg-event-db
::adjust-last
;; The last stroke's spacing, and the next one's: one setting, in the options
;; The last stroke's fit, and the next one's: one setting, in the options
;; bar and in the panel, as Blender's redo panel writes back to the tool.
(fn [db [_ spacing]]
(let [{:keys [pieces down sid frame ids]} (get-in db [:ui :last])
at (when pieces (landing-into db down (stroke-points pieces spacing)))]
(if (and pieces (= sid (:sid at)))
(-> db
(assoc-in [:ui :spacing] spacing)
(assoc-in [:ui :last :spacing] spacing)
(edit/transaction
(fn [c] (reduce (fn [c [id pts]] (paint/set-points c sid id frame pts))
c (map vector ids (:rings at))))))
db))))
(fn [db [_ fit]]
(let [{:keys [kind pieces paths ids down sid frame before after]} (get-in db [:ui :last])
;; Only while the document is still what the stroke left it as.
db (assoc-in db [:ui :fit] fit)]
(if-not (and pieces (identical? after (saved db)))
db
(let [db (if (= :eraser kind)
(erasing db before pieces fit paths ids)
(let [at (landing-into db down (stroke-points pieces fit))]
(edit/transaction
db (fn [c] (reduce (fn [c [id pts]] (paint/set-points c sid id frame pts))
c (map vector ids (:rings at)))))))]
(update-in db [:ui :last] assoc :fit fit :after (saved db)))))))
(rf/reg-event-db
::insert-vertex

13
frontend/src/arthur/subs/ui.cljs
View file

@ -34,7 +34,7 @@
(rf/reg-sub ::draft (fn [db _] (get-in db [:ui :draft])))
(rf/reg-sub ::hover (fn [db _] (get-in db [:ui :hover])))
(rf/reg-sub ::brush (fn [db _] (get-in db [:ui :brush] 6)))
(rf/reg-sub ::spacing (fn [db _] (get-in db [:ui :spacing] 6)))
(rf/reg-sub ::fit (fn [db _] (get-in db [:ui :fit] 1)))
(rf/reg-sub ::last-op (fn [db _] (get-in db [:ui :last])))
(rf/reg-sub ::convert (fn [db _] (get-in db [:ui :convert])))
@ -46,11 +46,12 @@
(rf/reg-sub
::last
:<- [::last-op]
:<- [::render/clip]
;; The last stroke, while what it made is still there to adjust: an undo takes
;; the panel away with the shapes.
(fn [[{:keys [sid ids] :as op} clip] _]
(when (and op (get-in clip [:symbols sid :nodes (first ids)])) op)))
:<- [::render/clip-id]
:<- [::render/paint-revision]
;; The last stroke while the document is still what it left: any other edit,
;; or an undo, takes the panel away, as Blender's goes with the next operation.
(fn [[op id _] _]
(when (and op (identical? (:after op) (:clip (store/entry id)))) op)))
(rf/reg-sub
::selected-node

119
frontend/src/arthur/ui/palette.cljs
View file

@ -14,13 +14,16 @@
The footage switch is NOT here. It is a viewing aid rather than something you
set before you draw, so it is a section of the inspector. See `ui/params`."
(:require [arthur.domain.node :as node]
(:require [arthur.domain.channel :as channel]
[arthur.domain.node :as node]
[arthur.domain.palette :as pal]
[arthur.domain.symbol :as symbol]
[arthur.events.project :as project]
[arthur.events.ui :as ui]
[arthur.subs.render :as render]
[arthur.subs.ui :as sub]
[re-frame.core :as rf]))
[re-frame.core :as rf]
[reagent.core :as r]))
(rf/reg-sub ::chosen (fn [db _] (get-in db [:ui :palette])))
@ -45,17 +48,101 @@
(when (seq edits)
(rf/dispatch [::project/set-channels edits]))))
(defn- swatch [pid i {:keys [name hex]} tone placements]
(let [picker-id (str "palette-picker-" pid "-" i)]
;; ---------------------------------------------------------------------------
;; remap: a shape that lights what is under it
;;
;; A shape coloured `[:remap {from to …}]` draws nothing of its own: whatever is
;; already under it is drawn in other slots of the same palette, as Deluxe
;; Paint's and Animator Pro's shade inks did. A flashlight is a circle of it.
;; Pick MAP from the strip and draw one; its map is set in the inspector, or by
;; dragging one swatch of the strip onto another while it is selected.
(defn- remap
"The selected node when it is a remap shape, with its map at the frame shown:
`{:sid :id :frame :keys :map}`, or nil."
[]
(let [[sid id n] @(rf/subscribe [::sub/selected-node])
frame (:frame @(rf/subscribe [::sub/selected-local]))
ch (get-in n [:channels [:style :color]])
c (when ch (channel/value-at ch (or frame 0) nil))]
(when (symbol/remap? c)
{:sid sid :id id :frame frame :keys (:keys ch) :map (second c)})))
(defn- map-slot!
"Light `from` as `to` under the selected remap shape; as itself, not at all."
[{:keys [sid id frame map]} from to]
(rf/dispatch [::project/set-channel sid id [:style :color] frame
[:remap (if (= from to) (dissoc map from) (assoc map from to))]]))
(defn remap-section
"The inspector's map for a selected remap shape: each slot as what is under
the shape will be drawn in, the original in its corner where it is changed.
A slot opens a choice of what to draw it as."
[]
(r/with-let [open (r/atom nil)]
(let [[_ _ palette] (shown)
{:keys [sid id frame keys] m :map :as rm} (remap)
slots (:slots palette)
hex #(:hex (get slots %))]
(when rm
[:section.section
[:h2 "remap"]
[:div.remap-head
[:button.key {:class (cond (contains? keys frame) "on" keys "keyed")
:disabled (nil? frame)
:title (if keys (str (count keys) " held keys") "key the map here")
:on-click #(rf/dispatch [::project/toggle-key sid id [:style :color] frame])}
"◆"]
[:span.dim (if (seq m)
(str "what is under it: " (count m) " slot" (when (< 1 (count m)) "s") " changed")
"changes nothing yet — pick a slot")]
[:span {:style {:flex 1}}]
(when (seq m)
[:button {:on-click #(rf/dispatch [::project/set-channel sid id [:style :color] frame [:remap {}]])}
"reset"])]
[:div.remap
(doall
(for [i (range (count slots))]
^{:key i}
[:button {:class (str "cell" (when (contains? m i) " mapped") (when (= i @open) " on"))
:style {:background (hex (get m i i))}
:title (str "slot " i (when (contains? m i) (str " → " (m i))))
:on-click #(swap! open (fn [o] (when-not (= o i) i)))}
(when (contains? m i) [:i {:style {:background (hex i)}}])]))]
(when-let [from @open]
[:div.remap-pick
[:span.dim (str "under it, draw " from " as")]
(doall
(for [i (range (count slots))]
^{:key i}
[:button {:class (str "cell" (when (= i (get m from from)) " on"))
:style {:background (hex i)}
:title (if (= i from) (str i " — as it is") (str "slot " i))
:on-click #(do (map-slot! rm from i) (reset! open nil))}]))])]))))
(defn- swatch [pid i {:keys [name hex]} tone placements rm hex-of]
(let [picker-id (str "palette-picker-" pid "-" i)
to (get (:map rm) i)]
[:div.slot {:key i}
[:button {:class (str "cell" (when (= i tone) " on"))
:style {:background hex}
:title (str "slot " i (when name (str " · " (clojure.core/name name)))
" · " hex " — double-click to edit")
" · " hex
(when to (str " · lit as " to " under the selected remap"))
" — double-click to edit"
(when rm ", drag onto another to remap it under the selected remap"))
:draggable (some? rm)
:on-drag-start #(.setData (.-dataTransfer %) "application/x-arthur-slot" (str i))
:on-drag-over (fn [^js e] (when rm (.preventDefault e)))
:on-drop (fn [^js e]
(.preventDefault e)
(let [from (js/parseInt (.getData (.-dataTransfer e) "application/x-arthur-slot"))]
(when (and rm (not (js/isNaN from))) (map-slot! rm from i))))
:on-click #(pick! i placements)
:on-double-click (fn [e]
(.preventDefault e)
(some-> (js/document.getElementById picker-id) (.click)))}]
(some-> (js/document.getElementById picker-id) (.click)))}
(when to [:i.badge {:style {:background (hex-of to)}}])]
[:input {:id picker-id :class "palette-picker" :type "color" :value hex
:aria-label (str "edit palette slot " i)
:on-change #(rf/dispatch [::project/palette-color pid i (.. % -target -value)])}]]))
@ -68,18 +155,24 @@
placements @(rf/subscribe [::sub/selected-placements])
hex (when (number? tone) (:hex (get (:slots palette) tone)))]
[:div.palette
[:div {:class (str "chip" (when (= :clear tone) " clear"))
[:div {:class (str "chip" (cond (= :clear tone) " clear" (symbol/remap? tone) " map"))
:style (when hex {:background hex})
:title (if (= :clear tone)
"clear: what is drawn knocks out what is under it in its symbol"
(str "slot " tone " · " hex))}
[:span (if (= :clear tone) "×" tone)]]
:title (cond (= :clear tone) "clear: what is drawn knocks out what is under it in its symbol"
(symbol/remap? tone) "remap: what is drawn lights what is under it"
:else (str "slot " tone " · " hex))}
[:span (cond (= :clear tone) "×" (symbol/remap? tone) "⇄" :else tone)]]
[:div.cells
(doall (map-indexed #(swatch pid %1 %2 tone placements) (:slots palette)))
(let [rm (remap) hex-of #(:hex (get (:slots palette) %))]
(doall (map-indexed #(swatch pid %1 %2 tone placements rm hex-of) (:slots palette))))
[:div.slot
[:button {:class (str "cell clear" (when (= :clear tone) " on"))
:title "clear — draws a knockout: a hole in its symbol"
:on-click #(pick! :clear placements)}]]]]))
:on-click #(pick! :clear placements)}]]
[:div.slot
[:button {:class (str "cell map" (when (symbol/remap? tone) " on"))
:title "remap — draws light: what is under it is drawn in other slots of the palette. Set which in the inspector."
:on-click #(pick! [:remap {}] placements)}
"⇄"]]]]))
(defn assets
"Which palette asset the grid shows, and a new or duplicated one, for the

11
frontend/src/arthur/ui/params.cljs
View file

@ -24,6 +24,7 @@
[arthur.subs.playback :as playback]
[arthur.subs.render :as render]
[arthur.subs.ui :as sub]
[arthur.ui.palette :as palette]
[re-frame.core :as rf]
[reagent.core :as r]))
@ -210,10 +211,11 @@
(defn- color-control [sid id ch frame auto-key? palette]
(let [keyed? (some? (:keys ch))
value (channel/value-at ch (or frame 0) nil)
value (if (integer? value)
value
(or (first (keep-indexed #(when (= value (:name %2)) %1)
(:slots palette))) 0))
;; A knockout or a remap is no slot, and none is marked.
value (cond
(integer? value) value
(keyword? value) (or (first (keep-indexed #(when (= value (:name %2)) %1)
(:slots palette))) 0))
off? (and keyed? (nil? frame))]
[:dd.channel {:class (when auto-key? "live")}
[:button.key {:class (cond (contains? (:keys ch) frame) "on" keyed? "keyed")
@ -826,6 +828,7 @@
[palette-placement-section node]
[clip-section])
(when (and node (not palette-placement?)) [node-section node])
(when (and node (not palette-placement?)) [palette/remap-section])
(when (and placed (not palette-placement?)) [symbol-section placed "source symbol"])
(when (and node (not palette-placement?)) ^{:key (str (first node) "/" (second node))}
[correction-section node])

76
frontend/src/arthur/ui/player.cljs
View file

@ -20,10 +20,12 @@
no global interceptors."
(:require [arthur.clock :as clock]
[arthur.domain.clip :as clip]
[arthur.domain.cut :as cut]
[arthur.domain.outline :as outline]
[arthur.domain.palette :as pal]
[arthur.domain.pick :as pick]
[arthur.domain.raster :as raster]
[arthur.domain.symbol :as symbol]
[arthur.events.playback :as pb]
[arthur.subs.playback :as sub]
[arthur.subs.render :as render]
@ -114,7 +116,7 @@
pen {:draft @(rf/subscribe [::ui-sub/draft])
:hover @(rf/subscribe [::ui-sub/hover])
:tone @(rf/subscribe [::ui-sub/tone])
:spacing @(rf/subscribe [::ui-sub/spacing])
:fit @(rf/subscribe [::ui-sub/fit])
;; Where a new shape would land, so what is being drawn
;; is drawn in that symbol's stacking context.
:target (:path @(rf/subscribe [::ui-sub/creation-target]))}]
@ -147,7 +149,7 @@
;; The brush or eraser stroke being painted: its mask, mutated in place as the
;; pointer moves, which is why it is an atom the stage pokes rather than state
;; anything renders from. `{:mask :version :slot :knock :target}`, `:mask` being an
;; anything renders from. `{:mask :version :slot :knock :paths}`, `:mask` being an
;; `outline/mask`.
(defonce ^:private stroke (atom nil))
(defonce ^:private trace-cache (atom nil))
@ -195,39 +197,67 @@
slot))
(defn- traced
"Stroke `s` as the polygons letting go would make of it: traced and
simplified by the same function the saved shapes are, so the preview IS them.
Once per version of the mask and spacing, not once per paint."
[{:keys [mask version]} spacing]
(let [key [mask version spacing]]
"Stroke `s` as the rings letting go would make of it, `[outer & holes]` per
piece: traced and simplified by the same function the saved shapes are, so
the preview IS them. Once per version of the mask and fit, not per paint."
[{:keys [mask version]} fit]
(let [key [mask version fit]]
(if (= key (:key @trace-cache))
(:polys @trace-cache)
(:polys (reset! trace-cache
(:rings @trace-cache)
(:rings (reset! trace-cache
{:key key
:polys (mapv #(outline/polygon % spacing) (outline/pieces mask))})))))
:rings (mapv #(outline/rings-of % fit) (outline/pieces mask))})))))
(defn- op-path [op] (let [n (:node op)] (if (vector? n) n [n])))
(defn- poly [ring op]
(assoc op :kind :poly :pts (into-array ring) :n (quot (count ring) 2)))
(defn- cut-ops
"`ops` with each op of a shape at one of `paths` cut by `cutters`, as the
eraser will cut it."
[ops paths cutters]
(into []
(mapcat (fn [{:keys [pts n] :as op}]
(or (when (and (= :poly (:kind op)) (contains? paths (op-path op)))
(some->> (cut/cut (vec (take (* 2 n) (array-seq pts))) cutters)
(map #(poly % (dissoc op :pts :n)))))
[op])))
ops))
(defn- inked
"Op `op` drawn in tone `tone`: a slot's colour, or — for a remap — light on
what is under it, through the same table the saved shape gets."
[op tone palette active]
(if (symbol/remap? tone)
(assoc op :lut (symbol/lut #(index-of-slot palette active %) tone) :color 0)
(assoc op :color (index-of-slot palette active tone))))
(defn- with-previews
"What is being drawn and is not in the document yet, added to `ops` in the
stacking context of the symbol it will land in: the pen's draft as far as the
pointer, and a stroke as the polygons it will be. A knockout goes INTO that
symbol's layer, so it clears what the saved one will and nothing else."
pointer, a brush stroke as the polygons it will be, and an eraser's cut as
the shapes it will leave."
[ops palette active]
(let [{:keys [draft hover tone spacing target]} (:pen @snapshot)
(let [{:keys [draft hover tone fit target]} (:pen @snapshot)
target (or target [])
pts (cond-> (vec draft) (and (seq draft) hover) (into hover))
{:keys [slot knock] :as s} @stroke
poly (fn [ring op] (assoc op :kind :poly :pts (into-array ring) :n (quot (count ring) 2)))]
{:keys [slot knock paths] :as s} @stroke
rings (when (:mask s) (traced s fit))]
(cond-> ops
(and (<= 6 (count pts)) (number? tone))
(clip/atop target (poly pts {:color (index-of-slot palette active tone)}))
(and (<= 6 (count pts)) (or (number? tone) (symbol/remap? tone)))
(clip/atop target (inked (poly pts {}) tone palette active))
(and (:mask s) (nil? knock))
(as-> ops (reduce #(clip/atop %1 target (poly %2 {:color (index-of-slot palette active slot)}))
ops (traced s spacing)))
paths
(cut-ops paths rings)
(and (:mask s) knock)
(as-> ops (reduce #(clip/in-layer %1 (or (:target s) target) (poly %2 {:color 0 :knock knock}))
ops (traced s spacing))))))
(and rings (not paths) (nil? knock))
(as-> ops (reduce #(clip/atop %1 target (inked (poly (outline/join %2) {}) slot palette active))
ops rings))
(and rings (not paths) knock)
(as-> ops (reduce #(clip/in-layer %1 target (poly (outline/join %2) {:color 0 :knock knock}))
ops rings)))))
(defn paint!
"Resolve `f` and put it on the canvas. `ops` are consumed here and only here —

69
frontend/src/arthur/ui/stage.cljs
View file

@ -17,6 +17,7 @@
[arthur.domain.outline :as outline]
[arthur.domain.paint :as paint]
[arthur.domain.pick :as pick]
[arthur.domain.symbol :as symbol]
[arthur.events.paint :as paint-events]
[arthur.events.ui :as ui]
[arthur.footage.store :as store]
@ -379,13 +380,15 @@
"`[i t]`: the edge of ring `pts` that stage point `p` is on, from point `i`
a fraction `t` of the way to the next — or nil."
[pts [x y]]
(let [ps (pairs pts) n (count ps)]
(let [ps (pairs pts) n (count ps)
;; Not a bridge: a point there would open the hole. See `outline-path`.
there (set (map (fn [i] [(ps i) (ps (mod (inc i) n))]) (range n)))]
(some (fn [i]
(let [[ax ay] (ps i) [bx by] (ps (mod (inc i) n))
dx (- bx ax) dy (- by ay)
l2 (+ (* dx dx) (* dy dy))
t (if (zero? l2) 0 (/ (+ (* (- x ax) dx) (* (- y ay) dy)) l2))]
(when (and (< 0.05 t 0.95)
(when (and (< 0.05 t 0.95) (not (contains? there [[bx by] [ax ay]]))
(<= (js/Math.hypot (- x (+ ax (* t dx))) (- y (+ ay (* t dy)))) 1.5))
[i t])))
(range n))))
@ -393,28 +396,36 @@
(defn- stroke-begin!
"Start painting with the brush, or erasing, at stage point `p`.
The eraser's target is the symbol holding what the stroke STARTS on, and it
clears that colour only — Photoshop's background eraser — or, with ⌥, every
colour. Starting on nothing with ⌥ erases in the open symbol."
The eraser cuts the shapes in the symbol holding what the stroke STARTS on,
of the colour it starts on — Photoshop's background eraser, Flash's erase
fills — or, with ⌥, every one of them. Starting on nothing with ⌥ cuts in
the open symbol."
[{:keys [open f] :as ctx} tool p size tone ^js event]
(let [eraser? (= :eraser tool)
all? (.-altKey event)
op (when eraser? (player/hit-op p))
path (when op (let [n (:node op)] (if (vector? n) n [n])))
all? (.-altKey event)
within (if path (pop path) [])
{document :clip st :store} (loaded ctx)
slot (when path
(when-let [{:keys [sid id frame]} (nest/placement document st open path f)]
(channel/value-at (get-in document [:symbols sid :nodes id :channels [:style :color]])
frame st)))
colour #(when-let [{:keys [sid id frame]} (nest/placement document st open % f)]
(when (get-in document [:symbols sid :nodes id :paint?])
(channel/value-at (get-in document [:symbols sid :nodes id :channels [:style :color]])
frame st)))
start (when path (colour path))
paths (when (and eraser? (or all? path))
(when-let [{:keys [sid]} (nest/inside document st open within f)]
(into #{}
(keep (fn [[id n]]
(let [q (conj within id) c (when (= :poly (:kind n)) (colour q))]
(when (and (some? c) (not (symbol/knockout? c)) (or all? (= c start)))
q))))
(get-in document [:symbols sid :nodes]))))
m (outline/stamp! (outline/mask (:w ctx) (:h ctx)) p p size)
s (cond
;; The brush's target is the creation target, which the player
;; reads for itself: nil here.
(not eraser?)
{:mask m :slot tone :knock (when (= :clear tone) -1)}
(or all? path)
{:mask m :knock (if all? -1 (:color op)) :target (if path (pop path) [])
:down (if path (pop path) []) :colour (if all? :clear [:clear slot])})]
;; reads for itself.
(not eraser?) {:mask m :slot tone :knock (when (= :clear tone) -1)}
(seq paths) {:mask m :paths paths})]
(if s
(do (reset! painting (assoc s :last p :size size :version 0))
(player/stroke! (assoc s :version 0)))
@ -428,11 +439,11 @@
(player/stroke! (swap! painting #(-> % (assoc :last p) (update :version inc))))))
(defn- stroke-end! []
(when-let [{:keys [mask down colour]} @painting]
(when-let [{:keys [mask paths]} @painting]
(reset! painting nil)
;; Synchronously, so the shapes are in the document before the preview of
;; them goes: otherwise the stroke blinks out for a frame in between.
(rf/dispatch-sync [::ui/stroke {:pieces (outline/pieces mask) :down down :colour colour}])
(rf/dispatch-sync [::ui/stroke {:pieces (outline/pieces mask) :paths paths}])
(player/stroke! nil)))
(defn- cursor
@ -442,6 +453,17 @@
(when-let [[x y] @pointer]
[:circle {:class (str "footprint " (name tool)) :cx x :cy y :r (/ size 2)}])))
(defn- outline-path
"Ring `pts` as an SVG path, without its bridges: an edge the ring runs along
both ways is where a hole is joined to the outside (see `domain/outline`),
which the fill never draws and the outline should not either."
[pts]
(let [ps (pairs pts) n (count ps)
edges (map (fn [i] [(ps i) (ps (mod (inc i) n))]) (range n))
there (set edges)]
(apply str (for [[a b] edges :when (not (contains? there [b a]))]
(str "M" (first a) "," (second a) "L" (first b) "," (second b))))))
(defn- points
"The pen on the selected shape: its points to drag, ⌥-click to delete, and a
marker where a click on an edge would add one."
@ -452,7 +474,7 @@
(on-edge pts @pointer))]
(when (and pts (not (channel/nothing? pts)))
[:g.points
[:polygon.outline {:points (points-text pts)}]
[:path.outline {:d (outline-path pts)}]
(when-let [[i t] edge]
(let [[ax ay] (nth (pairs pts) i) [bx by] (nth (pairs pts) (mod (inc i) (quot (count pts) 2)))]
[:circle.insert {:cx (+ ax (* t (- bx ax))) :cy (+ ay (* t (- by ay))) :r 1.6}]))
@ -501,7 +523,11 @@
pen? (= :pen tool)
;; The shape the pen is on, read while rendering: a click handler is
;; not a reactive context to subscribe from.
[esid eid egeom _ editable? eframe matrix] (when pen? (editing))
[esid eid egeom _ editable? eframe matrix] (editing)
selected-pts (when (and egeom matrix)
(let [pts (channel/value-at egeom eframe (:store (loaded ctx)))]
(when-not (channel/nothing? pts)
(through matrix pts))))
paints? (#{:brush :eraser} tool)
mark @marquee]
[:svg {:class (str "paint-overlay tool-" (name tool)
@ -594,6 +620,9 @@
(reset! painting nil) (player/stroke! nil)
(let-go! false))}
[ghost]
(when (seq selected-pts)
[:polygon.selected-paint-outline
{:points (points-text selected-pts) :pointer-events "none"}])
(when mark
(let [[[x0 y0] [x1 y1]] [(:p0 mark) (:p mark)]]
[:rect.marquee {:x (min x0 x1) :y (min y0 y1)

29
frontend/src/arthur/ui/tools.cljs
View file

@ -27,7 +27,7 @@
:icon [:<> [:path {:d "M15 1.5 L16.5 3 L9 10.5 L7.5 9 Z"}]
[:path {:d "M6.5 10 C4 10 3 11.5 3 13.5 C3 15 1.5 16 1.5 16 C5 16 8 15 8 11.5 Z"}]]}
{:tool :eraser :key "e" :name "Eraser"
:tip "erases the colour you start on, in its symbol · ⌥ erases every colour"
:tip "cuts the shapes of the colour you start on, in its symbol · ⌥ cuts every colour"
:icon [:<> [:path {:d "M10 2.5 L16 8.5 L10 14.5 L5.5 14.5 L2 11 Z"}]
[:path.cut {:d "M6 6.5 L12 12.5"}]]}])
@ -51,13 +51,16 @@
:on-change #(rf/dispatch [::ui/brush-size (js/parseInt (.. % -target -value))])}]
[:span.value (str size "px")]]))
(defn- spacing-control
"A point every so many pixels of outline: the brush's detail, by length."
[spacing event]
[:label.option {:title "fewer pixels between points is more detail"} "a point every"
[:input {:type "range" :min 1 :max 40 :value spacing
:on-change #(rf/dispatch [event (js/parseInt (.. % -target -value))])}]
[:span.value (str spacing "px")]])
(defn- fit-control
"How closely a stroke's polygon follows what was painted: every point of the
painted edge within so many pixels of it. Closer is more points, and only
where the shape bends."
[fit event]
[:label.option {:title "how far the polygon may stray from what you painted — closer is more points, only where it bends"}
"fit within"
[:input {:type "range" :min 0.5 :max 8 :step 0.5 :value fit
:on-change #(rf/dispatch [event (js/parseFloat (.. % -target -value))])}]
[:span.value (str fit "px")]])
(defn options []
(let [tool @(rf/subscribe [::sub/tool])
@ -75,7 +78,7 @@
[:button {:on-click #(rf/dispatch [::ui/cancel-polygon])} "discard"]]
[:span.dim.hint tip])
(:brush :eraser) [:<> [size-control]
[spacing-control @(rf/subscribe [::sub/spacing]) ::ui/spacing]
[fit-control @(rf/subscribe [::sub/fit]) ::ui/fit]
[:span.dim.hint tip]]
(if (< 1 (count selections))
[:span.dim (str (count selections) " selected")]
@ -87,14 +90,14 @@
[layout/zoomer :stage "the stage"]]))
(defn adjust-last
"Blender's Adjust Last Operation, for a brush or eraser stroke: its spacing,
"Blender's Adjust Last Operation, for a brush or eraser stroke: its fit,
changeable until something else is done."
[]
(when-let [{:keys [kind ids spacing]} @(rf/subscribe [::sub/last])]
(when-let [{:keys [kind ids fit]} @(rf/subscribe [::sub/last])]
[:div.adjust-last
[:strong (if (= :eraser kind) "Erase" "Brush stroke")]
(when (< 1 (count ids)) [:span.dim (str (count ids) " pieces")])
[spacing-control spacing ::ui/adjust-last]]))
(when (and (= :brush kind) (< 1 (count ids))) [:span.dim (str (count ids) " pieces")])
[fit-control fit ::ui/adjust-last]]))
(defn- typing?
"Is a key going into a field? A slider or a checkbox has focus without

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"))))