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

Port steps 0-1: scaffold, the oracle, and the pure bottom

Browse source 
Scaffolds frontend/ (shadow-cljs, reagent 1.2.0, re-frame 1.4.3) and ports
everything below the data model, with the JS kept as a numeric oracle.

  domain/landmarks  index tables, verbatim
  domain/ring       subsample, offset, simplicity
  domain/geom       similarity fit, procrustes, moving average
  domain/raster     indexed scanline fill, stencil, disc, rect
  domain/palette    the ramp, and the no-sampled-RGB rule

58 tests, 166 assertions. Parity with js/ on the identical 72-frame synthetic
track: fit-similarity, procrustes-mean, fit-residual, moving-average,
smooth-transforms, offset-ring and subsample-slots to 1e-9; the raster
pixel-for-pixel over the whole buffer.

Three deviations from the JS, each for a reason:

- synth.cljs jitters from a SEEDED generator, not Math.random. Parity is only
  checkable if both sides can be handed the same track, and a failing assertion
  has to be reproducible. `:rand-fn` takes the generator over, so oracle.mjs
  stubs js/Math.random and js/ itself stays untouched.

- raster/->rgba replaces toImageData. ImageData is a DOM type and domain/ may
  not touch the DOM; returning plain bytes also lets the
  no-intermediate-colours assertion run in node. ui/canvas wraps it later.

- offset-ring lives in domain/ring, not domain/geom, per architecture.md: it is
  an operation on an ordered traversal, not on a transform.

Step 1's "done" also names the swapped-iris vote, but pairIrises is in
pipeline.js and belongs to step 7. The precondition is asserted instead --
`:swap-iris` really does move both blocks -- so the vote will have a track that
disagrees with it when it arrives.

One finding, recorded in full in the test that measures it: smooth-transforms
buys nothing on the synthetic track. Against jitter-free ground truth, radius 1
helps by 17% on one noise realisation and hurts by 0.5% on another, so its
benefit is within noise; from radius 2 up the cost is unambiguous, and by radius
5 the filter is below the true motion's own high-frequency energy, i.e.
smoothing away performance. The test pins the shape of the knob rather than a
preferred value. This may say more about the synth's jitter being unrealistically
small (+/-0.001 normalised) than about the knob; step 6 settles it on real
footage.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
This commit is contained in:
Olive Vaughn 2026-09-27 14:43:34 -04:00
parent 082d8561d2
commit eb06be005c
25 changed files with 4932 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

19
frontend/src/arthur/core.cljs Normal file
View file

@ -0,0 +1,19 @@
(ns arthur.core
"The app's one entry point. Deliberately almost empty until port-plan step 2:
there is nothing to render until the data model exists, and a shell built
before the model would be a shell built around a guess."
(:require [reagent.dom.client :as rdc]))
(defonce root (atom nil))
(defn shell []
[:main
[:h1 "arthur"]
[:p "Scaffold only. The scene renderer arrives with domain/scene."]])
(defn ^:dev/after-load mount []
(rdc/render @root [shell]))
(defn init []
(reset! root (rdc/create-root (js/document.getElementById "app")))
(mount))

130
frontend/src/arthur/domain/geom.cljs Normal file
View file

@ -0,0 +1,130 @@
(ns arthur.domain.geom
"2D similarity transforms and temporal smoothing.
A transform is {:s :theta :tx :ty}; a point is {:x :y}. Both stay maps at this
layer: this is the numeric oracle the JS is diffed against, and a faithful
port is worth more here than a fast one. The dense typed-array
representations appear at the freeze boundary, not below it.")
(defn fit-similarity
"Least-squares similarity (translation + rotation + uniform scale, 4 DOF)
mapping P onto Q. Closed form; no iteration.
Deliberately NOT affine or homography: the extra degrees of freedom absorb
out-of-plane head rotation as shear/perspective and smear it into the mouth.
Four DOF removes exactly translation, roll and depth-scale, and leaves yaw and
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)]))
[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
(+ b (- (* px qy) (* py qx))) ; cross
(+ norm (+ (* px px) (* py py)))))
[a b norm]))
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
;; otherwise poison the Procrustes mean and therefore every frame.
s (if (> norm 1e-12) (/ (js/Math.hypot a b) norm) 1)
c (js/Math.cos theta)
sn (js/Math.sin theta)]
{:s s
:theta theta
:tx (- qcx (* s (- (* c pcx) (* sn pcy))))
:ty (- qcy (* s (+ (* sn pcx) (* c pcy))))}))
(defn apply-sim [tf p]
(let [c (js/Math.cos (:theta tf))
sn (js/Math.sin (:theta tf))]
{:x (+ (* (:s tf) (- (* c (:x p)) (* sn (:y p)))) (:tx tf))
:y (+ (* (:s tf) (+ (* sn (:x p)) (* c (:y p)))) (:ty tf))}))
(defn apply-sim-all [tf pts]
(mapv #(apply-sim tf %) pts))
(defn fit-residual
"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)]
(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))))
(defn procrustes-mean
"Generalised Procrustes: the reference is the MEAN rigid configuration over the
shot, not frame zero, so no single frame's idiosyncrasies get baked into every
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
(->> 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))})
acc moved)))
(mapv (constantly {:x 0.0 :y 0.0}) ref))
(mapv (fn [p] {:x (/ (:x p) n) :y (/ (:y p) n)})))
(inc iter)))))))
(defn moving-average
"`radius` is in frames either side: 0 is off, 1 averages over 3 frames, 2 over
5. Expressed as a radius rather than a window so that \"off\" is 0 and every
value is symmetric - an even window would be lopsided in time."
[vals radius]
(if (<= radius 0)
(vec vals)
(let [v (vec vals)
n (count v)
half (js/Math.floor radius)]
(mapv (fn [i]
;; Clamped at the ends rather than shortened, so every output is an
;; average of the same COUNT of samples and the first frame is not
;; noisier than the rest.
(let [lo (- i half) hi (+ i half)]
(/ (reduce + (map (fn [j] (nth v (min (dec n) (max 0 j))))
(range lo (inc hi))))
(inc (- hi lo)))))
(range n)))))
(defn smooth-transforms
"Smooth the four transform parameters, NEVER the contour. Landmark jitter of a
pixel is smeared into the mouth by the inverse transform, so the transform is
where the low-pass belongs; smoothing the contour would destroy the
performance, which is the entire asset.
Angles are smoothed as (cos, sin) so wrapping cannot produce a spike."
[tfs radius]
(let [c (moving-average (map #(js/Math.cos (:theta %)) tfs) radius)
sn (moving-average (map #(js/Math.sin (:theta %)) tfs) radius)
s (moving-average (map :s tfs) radius)
tx (moving-average (map :tx tfs) radius)
ty (moving-average (map :ty tfs) radius)]
(mapv (fn [i] {:theta (js/Math.atan2 (nth sn i) (nth c i))
:s (nth s i)
:tx (nth tx i)
:ty (nth ty i)})
(range (count tfs)))))

115
frontend/src/arthur/domain/landmarks.cljs Normal file
View file

@ -0,0 +1,115 @@
(ns arthur.domain.landmarks
"MediaPipe FaceLandmarker index tables.
Ring vectors are ORDERED traversals, not raw connection sets: vertex position
within a ring is the vertex's identity, and every downstream stage depends on
that ordering being stable. See docs/design.md, \"Fixed topology\".
Tables only. The operations over a ring — subsample, offset, simplicity —
live in arthur.domain.ring, because they are about ordered traversals in
general and know nothing about faces.")
;; Rigid landmarks for the similarity fit. Eye corners, nose bridge, nose tip.
;; Nothing here may be a feature that moves under performance: including the
;; mouth or brows bleeds performance into the stabilization.
(def RIGID [33 133 362 263 168 6 1])
;; Outer lip ring, clockwise from the right corner over the top.
;; index 0 = right corner, 5 = top centre, 10 = left corner, 15 = bottom centre.
(def LIPS-OUTER
[61 185 40 39 37 0 267 269 270 409
291 375 321 405 314 17 84 181 91 146])
;; Inner lip ring, same orientation and the same four cardinal positions.
(def LIPS-INNER
[78 191 80 81 82 13 312 311 310 415
308 324 318 402 317 14 87 178 88 95])
;; Inner upper / lower lip centres. Their separation is the aperture signal that
;; decides whether the mouth interior is present at all.
(def APERTURE [13 14])
;; Face oval, used only to derive the placeholder plate in v1.
(def FACE-OVAL
[10 338 297 332 284 251 389 356 454 323 361 288
397 365 379 378 400 377 152 148 176 149 150 136
172 58 132 93 234 127 162 21 54 103 67 109])
;; Eye corners, for the calibration box and for reporting fit residual.
(def EYE-INNER [133 362])
;; ---- eyes ----
;;
;; Eyelid rings, under the same contract as the lip rings: ORDERED traversals
;; where slot position IS vertex identity. Both eyes start at the OUTER corner
;; and go over the UPPER lid first, so slot k means the same anatomy on both
;; sides. On a 16-slot ring that puts the four cardinals exactly on the four
;; quarter slots - 0 outer corner, 4 upper lid centre, 8 inner corner, 12 lower
;; lid centre - so every even vertex budget lands on real landmarks.
;;
;; The two rings traverse opposite directions on screen, because they are
;; mirrored anatomy described the same way. Nothing downstream cares: an
;; even-odd fill has no winding, and ring SIMPLICITY is what is asserted.
(def EYE-R-RING
[33 246 161 160 159 158 157 173
133 155 154 153 145 144 163 7])
(def EYE-L-RING
[263 466 388 387 386 385 384 398
362 382 381 380 374 373 390 249])
;; Outer, inner corner per eye. All four are also in RIGID, and that is the
;; point: the eye's reference frame is built only from landmarks that do not
;; move under performance, so a blink cannot be mistaken for a change of gaze.
(def EYE-R-CORNERS [33 133])
(def EYE-L-CORNERS [263 362])
;; Upper and lower lid centres. Their separation over the corner distance is the
;; openness signal that decides whether the eye is shut - the same shape of
;; measurement as APERTURE is for the mouth, but normalised, so one threshold
;; carries across takes and faces.
(def EYE-R-LIDS [159 145])
(def EYE-L-LIDS [386 374])
;; The two iris blocks the refined mesh appends: centre first, then four ring
;; points. WHICH BLOCK BELONGS TO WHICH EYE IS NOT DECLARED HERE - MediaPipe's
;; own "left"/"right" is viewer-relative in some docs and subject-relative in
;; others, and a swap looks almost right, so it would survive an eyeball and
;; then read as a permanently wall-eyed character. flow/measure/eyes resolves it
;; from the geometry instead.
(def IRIS-A [468 469 470 471 472])
(def IRIS-B [473 474 475 476 477])
;; ---- brows ----
;;
;; Each brow is two five-point chains, an upper edge and a lower edge, which
;; close into a ten-point ring: out along one edge from the outer end to the
;; inner, back along the other.
;;
;; WHICH EDGE IS UPPER IS DELIBERATELY NOT DECLARED, and unlike the iris it does
;; not need to be. Swapping them traverses the same ring the other way round,
;; and an even-odd fill has no winding, so the shape is identical either way.
;; What the ring guarantees instead is that the two ENDS land on fixed slots:
;; 0 and 9 are one end, 4 and 5 the other. Averaging a pair therefore gives the
;; brow's height at that end whichever edge is on top, which is all the raise
;; and tilt measurement needs.
;;
;; Which end is the OUTER one is resolved from geometry in flow/measure/brows,
;; because getting it backwards mirrors the tilt - inner-up "worried" would
;; render as outer-up - and that is an expression error, not a glitch, so it
;; would read as a directed performance choice rather than as a bug.
(def BROW-A-RING
[70 63 105 66 107
55 65 52 53 46])
(def BROW-B-RING
[300 293 334 296 336
285 295 282 283 276])
;; The slots at each end of a brow ring, as pairs to average.
(def BROW-END-0 [0 9])
(def BROW-END-1 [4 5])
;; The number of landmarks the refined mesh emits: 468 face + 10 iris. Dense
;; frames are this long whether or not the iris blocks carry anything.
(def NUM-LANDMARKS 478)

50
frontend/src/arthur/domain/palette.cljs Normal file
View file

@ -0,0 +1,50 @@
(ns arthur.domain.palette
"The indexed palette.
THE RULE, and it is a rule rather than a default: a part carries a palette
INDEX, never a sampled RGB value. Sampling colour off the footage produces a
pixel-art filter, and it does so irrecoverably — once a shape holds a measured
colour there is no way back to an authored one, because the information that it
was ever a choice is gone. Every `[:style :color]` channel holds one of the
keywords below.
Entries are ordered, and the order IS the index the raster writes. Inserting in
the middle renumbers every stored index, so new tones append.")
(def entries
[{:name :bg :hex "#12141c"}
{:name :skin-base :hex "#b07a5a"}
{:name :skin-dark :hex "#7a4f3a"}
{:name :mouth-dark :hex "#24161a"}
{:name :teeth :hex "#d9cfc2"}
;; Sclera is not white, and that is authored, not measured. A true white at
;; 320x200 next to a warm skin ramp reads as a hole punched in the face; the
;; eye sits in a socket, in shadow, so it is a dimmer and cooler tone than the
;; teeth, which catch the light.
{:name :eye-white :hex "#c9c3b4"}
;; Three tones for the eye - sclera, iris, pupil - which is the "two or three
;; tones per part" budget, spent where it buys the most: an eye with no tonal
;; step inside it reads as a hole.
{:name :iris :hex "#4a5468"}
{:name :pupil :hex "#171a22"}
;; Brows get their own entry rather than sharing skin-dark with the lash line.
;; They are hair, not shadow: when hair plates exist they want to match those,
;; and tying them to the lash means you cannot change one without the other.
{:name :brow :hex "#3a2a22"}])
(def hexes (mapv :hex entries))
(def index-of
"Palette keyword -> the index the raster writes. Derived, so the vector above
is the single place an ordering is declared."
(into {} (map-indexed (fn [i e] [(:name e) i]) entries)))
(defn hex->rgb [hex]
(let [s (.replace hex "#" "")]
[(js/parseInt (.slice s 0 2) 16)
(js/parseInt (.slice s 2 4) 16)
(js/parseInt (.slice s 4 6) 16)]))
(def rgb
"Index -> [r g b], precomputed."
(mapv hex->rgb hexes))

150
frontend/src/arthur/domain/raster.cljs Normal file
View file

@ -0,0 +1,150 @@
(ns arthur.domain.raster
"Indexed flat-fill rasteriser.
Canvas2D antialiases path fills, and antialiasing is exactly what the target
idiom does not have: Animator Pro fills polygons into a 256-colour indexed
raster with hard edges (csd_render_poly). A preview that antialiases would
misrepresent the look it exists to judge, so this writes palette indices into
a byte buffer with an even-odd scanline fill and expands to RGBA only at the
very end.
A raster is {:w :h :buf} where :buf is a Uint8Array, and the fill functions
MUTATE it and return it. That is deliberate and it is the one place in domain/
that mutates: a persistent 64000-entry vector rebuilt per draw op per frame is
not a rasteriser. The mutation is confined — a raster is created, filled and
blitted inside one frame, and never stored in app-db.
No DOM here. `->rgba` returns plain bytes; wrapping them in an ImageData is
ui/canvas's job, which is also what lets every assertion below run in node.")
(defn make [w h]
{:w w :h h :buf (js/Uint8Array. (* w h))})
(defn clear! [{:keys [buf] :as r} index]
(.fill buf index)
r)
(defn fill-poly!
"Even-odd scanline fill. Samples at pixel centres (y + 0.5), so a polygon
edge landing exactly on a pixel boundary resolves consistently."
[{:keys [w h buf] :as r} pts index]
(let [n (count pts)]
(when (>= n 3)
(let [ys (map :y pts)
y0 (max 0 (js/Math.ceil (- (apply min ys) 0.5)))
y1 (min (dec h) (inc (js/Math.floor (- (apply max ys) 0.5))))]
(doseq [y (range y0 (inc y1))]
(let [sy (+ y 0.5)
xs (sort
(for [i (range n)
:let [a (nth pts i)
b (nth pts (mod (inc i) n))]
;; A horizontal edge contributes no crossing, and
;; dividing by its zero height would emit Infinity.
:when (not= (:y a) (:y b))
:let [lo (min (:y a) (:y b))
hi (max (:y a) (:y b))]
;; 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))]
(+ (:x a) (* (/ (- sy (:y a)) (- (:y b) (:y a)))
(- (:x b) (:x a))))))]
(when (>= (count xs) 2)
(doseq [[xa xb] (partition 2 xs)]
(let [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)))))))))))
r))
(defn fill-disc!
"`over` is an optional stencil: when given, only pixels that currently hold
that index are written. The indexed buffer is its own clip mask, which is
how Animator Pro would do it - and it is what keeps the iris inside the
eye. A disc clipped by the sclera cannot spill past the lid at any gaze or
any radius, including mid-blink when the opening is a two-pixel sliver, so
the lid crops the iris for free instead of the gaze range needing a
clamp that would flatten the performance at the extremes."
([r cx cy rad index] (fill-disc! r cx cy rad index nil))
([{:keys [w h buf] :as r} cx cy rad index over]
(let [rr (* rad rad)
y0 (max 0 (js/Math.floor (- cy rad)))
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)
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))))
r)))
(defn fill-rect!
"An exactly size x size block of pixels, snapped to the pixel grid, with the
same optional stencil as fill-disc!.
The pupil is a SQUARE because at 320x200 it is three pixels across, and a
circle of radius 1.5 is not a circle - it is a plus sign with the corners
gnawed off, and it changes shape as it moves. A square that size is a
deliberate mark that stays the same mark wherever it lands, which is the
whole argument for flat shapes at this resolution.
The top-left is rounded rather than the centre, so the block is size x size
on every frame. Round the extents instead and a fractional centre gives you
three pixels on one frame and four on the next, which reads as the pupil
breathing."
([r cx cy size index] (fill-rect! r cx cy size index nil))
([{:keys [w h buf] :as r} cx cy size index over]
(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)]
(when (or (nil? over) (= (aget buf o) over))
(aset buf o index)))
(recur (inc x))))
(recur (inc y))))))
r))
(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."
([r palette-rgb] (->rgba r palette-rgb 1))
([{:keys [w h buf]} palette-rgb zoom]
(let [W (* w zoom)
H (* h zoom)
d (js/Uint8ClampedArray. (* W H 4))]
(loop [y 0]
(when (< 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])
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))))
{:width W :height H :data d})))

96
frontend/src/arthur/domain/ring.cljs Normal file
View file

@ -0,0 +1,96 @@
(ns arthur.domain.ring
"Operations on an ordered ring of points.
A ring here is a closed traversal: a vector of points where slot k means the
same thing on every frame of a shot. That is what makes temporal
correspondence possible at all, so nothing in here is allowed to reorder,
insert or adaptively decimate — every function is index-preserving or returns
slot positions.")
(defn subsample-slots
"Pick `n` slots from a ring of `len` by even spacing. Returns RING POSITIONS,
not landmark ids: positions are the vertex identity downstream, and mapping ids
back to positions with indexOf would silently pick the wrong slot if a table
ever repeated an id.
For even n this naturally lands on the cardinal positions (corners and lip
centres) of a 20-point ring. Fixed indices, never adaptive decimation: the
vertex at slot k means the same thing on every frame of the shot."
[len n]
(mapv (fn [k] (mod (js/Math.round (/ (* k len) n)) len)) (range n)))
(defn subsample-ring
"`subsample-slots` applied to a table, yielding landmark ids."
[ring n]
(mapv #(nth ring %) (subsample-slots (count ring) n)))
(defn offset-ring
"Push a ring outward from its centroid by a FIXED distance, not by a scale
factor.
Scaling collapses with the shape: a shut eyelid scaled by 1.1 is still a shut
eyelid, so the lash line - the only thing left to draw when the eye is closed
- would vanish exactly on the frames where it is the whole drawing. A fixed
radial offset gives a band of roughly constant thickness that survives the
ring going degenerate, and it keeps a star-shaped ring simple, which
docs/design.md requires of every cut part."
[pts d]
(if (or (nil? d) (zero? d))
pts
(let [n (count pts)
cx (/ (reduce + (map :x pts)) n)
cy (/ (reduce + (map :y pts)) n)]
(mapv (fn [p]
(let [dx (- (:x p) cx)
dy (- (:y p) cy)
m (js/Math.hypot dx dy)]
;; A vertex sitting exactly on the centroid has no outward
;; direction. Leave it where it is rather than emitting NaN and
;; poisoning the whole ring.
(if (< m 1e-9)
{:x (:x p) :y (:y p)}
{:x (+ (:x p) (* (/ dx m) d))
:y (+ (:y p) (* (/ dy m) d))})))
pts))))
(defn- orient
"Sign of the cross product (p->q) x (p->r): which side of pq the point r is on."
[p q r]
(js/Math.sign (- (* (- (:x q) (:x p)) (- (:y r) (:y p)))
(* (- (:y q) (:y p)) (- (:x r) (:x p))))))
(defn segments-cross?
"True when ab and cd cross properly. Collinear and touching cases are
deliberately NOT crossings: adjacent ring edges share an endpoint, and a
degenerate ring — the shut eyelid — has collinear ones. Reporting those would
make the simplicity assertion fire on exactly the shapes it has to allow."
[a b c d]
(let [o1 (orient a b c) o2 (orient a b d)
o3 (orient c d a) o4 (orient c d b)]
(and (not= o1 o2) (not= o3 o4)
(not (zero? o1)) (not (zero? o2))
(not (zero? o3)) (not (zero? o4)))))
(defn self-intersections
"Every pair of non-adjacent edges of the closed ring that cross, as [i j].
This exists because \"fixed topology\" is load-bearing: because hold parts CUT
between poses rather than interpolating, a ring whose vertex order is wrong
self-intersects and renders as blocks meeting at corners. It is invisible at
odd vertex counts and obvious at even ones, so it needs an assertion rather
than an eyeball."
[pts]
(let [n (count pts)
at (fn [i] (nth pts (mod i n)))]
(vec
(for [i (range n)
j (range (inc i) n)
:when (and (not= (mod (inc j) n) i)
(not= (mod (inc i) n) j))
:when (segments-cross? (at i) (at (inc i)) (at j) (at (inc j)))]
[i j]))))
(defn simple?
"True when no pair of non-adjacent edges crosses."
[pts]
(empty? (self-intersections pts)))