moonlight-planar 1.1.0.0 → 1.2.0.0

raw patch · 38 files changed

+5955/−584 lines, 38 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +107/−0
• README.md +4/−3
• bench/curve/Main.hs +3/−1
• bench/curve/Moonlight/Planar/MeasureBench.hs +173/−0
• bench/curve/Moonlight/Planar/RegionBench.hs +114/−0
• docs/art-common/Moonlight/Planar/Exhibit/EquationalGarden.hs +69/−32
• docs/art-common/Moonlight/Planar/Exhibit/SpaceSword.hs +93/−33
• docs/curve-authoring-status.md +130/−0
• docs/illustration-study/Main.hs +4/−4
• moonlight-planar.cabal +25/−2
• src-core/Moonlight/Planar/Internal/ExactRational.hs +32/−0
• src-dcel/Moonlight/Planar/Curve.hs +187/−34
• src-dcel/Moonlight/Planar/Curve/Frame.hs +180/−0
• src-dcel/Moonlight/Planar/Curve/Lowering.hs +3/−3
• src-dcel/Moonlight/Planar/Curve/Measure.hs +522/−0
• src-dcel/Moonlight/Planar/Curve/Proximity.hs +485/−0
• src-dcel/Moonlight/Planar/Curve/Region.hs +384/−13
• src-dcel/Moonlight/Planar/Internal/CurveBudget.hs +56/−0
• src-dcel/Moonlight/Planar/Internal/CurveCertificate.hs +240/−0
• src-dcel/Moonlight/Planar/Internal/CurveSource.hs +246/−0
• src-dcel/Moonlight/Planar/Internal/Length.hs +424/−0
• src-dcel/Moonlight/Planar/Internal/Region/Loop.hs +157/−0
• src-dcel/Moonlight/Planar/Region.hs +13/−103
• src-dcel/Moonlight/Planar/Valuation.hs +60/−291
• src-illustration/Moonlight/Planar/Illustration/Layout.hs +44/−25
• test/algebra/Moonlight/Planar/ValuationSpec.hs +113/−0
• test/curve/Main.hs +6/−1
• test/curve/Moonlight/Planar/CurveCertificateSpec.hs +409/−0
• test/curve/Moonlight/Planar/CurveFrameSpec.hs +198/−0
• test/curve/Moonlight/Planar/CurveLoweringSpec.hs +5/−4
• test/curve/Moonlight/Planar/CurveMeasureSpec.hs +446/−0
• test/curve/Moonlight/Planar/CurveProximitySpec.hs +273/−0
• test/curve/Moonlight/Planar/CurveSourceSpec.hs +118/−0
• test/curve/Moonlight/Planar/CurveSpec.hs +220/−8
• test/illustration/Moonlight/Planar/EquationalGardenSpec.hs +83/−2
• test/illustration/Moonlight/Planar/IllustrationStudySpec.hs +87/−17
• test/illustration/Moonlight/Planar/LayoutSpec.hs +106/−0
• test/illustration/Moonlight/Planar/SpaceSwordSpec.hs +136/−8

@@ -10,6 +10,113 @@ The serialization format carries its own version tag, independent of the package version; any change to it is recorded here explicitly. +## 1.2.0.0 - 2026-09-23++* Breaking: remove `splitStepHalf` from `Moonlight.Planar.Curve`. Use+  `splitStep unitHalf`, or `splitStep` at any exact parameter; there is no+  compatibility alias.+* Add `splitStep`, exact de Casteljau subdivision at an arbitrary+  `UnitInterval` for lines, quadratics, cubics and positive-weight rational+  quadratics. Each child is reparameterized over its own unit interval, and the+  right child is rebased at the split point.+* Add `ParameterSpan` (an ordered, checked pair of unit parameters, refused+  with `ReversedParameterSpan`) and `restrictStep`, which reparameterizes a+  located step to the span through polar forms and relocates it to the source+  point. Equal endpoints yield a stationary step.+* Add `StepJet` and `jetStep`: the value and the first and second derivatives+  with respect to the step's own parameter. The rational quadratic uses the+  homogeneous quotient rule with a positive weight witness. `startJet` and+  `endJet` remain as closed-form endpoint specializations.+* Add `Moonlight.Planar.Curve.Measure`: certified Euclidean arc length of+  lines, quadratics, cubics and positive-weight rational quadratics as an+  immutable `MeasuredTrail` that retains its source subpath, accepted spans and+  cumulative rational enclosures.+  * One chord/control-polygon enclosure kernel serves all four shapes.+  * A global error allocation keeps the total width within the policy+    tolerance.+  * `measurePolicy` is total over a tolerance, a `RadicalPrecision` and an+    admitted `SubdivisionBudget` (depth, leaves, exact bit width), which+    `subdivisionBudget` validates. The bit budget covers source values,+    retained values and query requests. An exhausted budget refuses as+    `MeasureBudgetExhausted` carrying the shared `BudgetObligation`.+  * `pointAtLength` and `pointAtFraction` answer inverse queries as an+    `ArcSample`: a site on its source step with a certified parameter bracket+    and a residual within tolerance.+  * A `TrailSite` is an opaque located position on one step of its source,+    with its step index, `UnitInterval` parameter, exact point, join side and+    jet. `sampleSite` reads the site of an `ArcSample`. The sample itself adds+    only the bracket and the residual.+  * Span and sample parameters, and those carried by `SpanRefused`, are+    `UnitInterval` values admitted once and never rechecked.+  * A distance beyond the certified upper length is refused, and so is one+    between the lower and upper lengths of an inexact total. Neither is+    clamped.+  * Exhausted budgets refuse with the source step, the bracket and the+    obligation.+* Add `Moonlight.Planar.Curve.Frame`: measured tangent frames for+  path-directed placement.+  * `regularFrame` reads a `FrameSite`, either a sampled `ArcSample` or an+    exact `TrailSite` from `exactTrailSite`, through one jet and+    normalization path.+  * The first column is the tangent and the second is its left normal+    `(-t_y, t_x)`. The frame carries its certified scale bound+    (`measuredFrameScaleSquared`).+  * A stationary site, a corner (including a closed seam), an out-of-range+    step or an unresolved normalization is refused. No tangent is invented.+  * `fractionRun` and `sampleRun` place an evenly spaced run of arc fractions.+    An empty run, non-positive spacing and a closed seam repeated at both ends+    are refused.+* Breaking: `Moonlight.Planar.Curve.Region.lowerSimpleRegion` now takes a+  `SubdivisionBudget` and returns `CurveTopologyEvidence` with the region and+  lowered paths. It certifies that the region's components, holes and nesting+  are the curves' own, within a stated domain:+  * each contour subdivides within budget into monotone pieces;+  * each joint is wedge-separated (a cusp refuses);+  * non-adjacent pieces are hull-separated or certified not to cross;+  * the actual lowered loops nest exactly as the curves do.++  Outside that domain it refuses with `CurveTopologyRefused`, a new+  `CurveRegionError` constructor. Its obstructions name the contour spans and+  keep three kinds of case apart:+  * certified contacts, which carry an exact common source point;+  * certified crossings, which carry a certificate and never a point;+  * unresolved contacts, which carry the exhausted budget.++  Every retained piece's located controls and every crossing certificate are+  admitted against the budget's bit width. `certifySimpleRegion` certifies+  without lowering, and+  `certifiedPointLocation` locates a point strictly outside every certified+  piece hull. There is no uncertified variant.+* Add `Moonlight.Planar.Curve.Proximity`: bounded distance and clearance+  between two curves.+  * `curveDistance` returns an enclosure of the distance within the policy+    tolerance, with its live candidate span pairs. The pairs are never a claim+    that the nearest pair is unique.+  * `clearance` is strict: it holds when the distance exceeds the given+    distance, so zero means disjoint.+  * Contact is witnessed in exactly three ways:+    * exact sites closer than the distance;+    * an exact shared site;+    * a certified transversal crossing, which carries no point.+  * Distance and contact are separate: a tangency can have its distance+    decided while its contact stays unresolved.+  * The subdivision budget's bit width bounds every source span, retained+    site, displacement, certificate and enclosure endpoint, and the clearance+    threshold at entry.+    * An oversized request refuses before any work, as+      `ProximityRequestRefused`.+    * More source-step pairs than the budget's leaves refuse from the step+      counts alone, as `ProximityStepPairsRefused`, before any pair is built.+    * A source step too wide for the budget refuses as+      `ProximitySourceRefused`, naming the span.+    * A failure before any enclosure exists refuses without one, as+      `ProximityUnenclosed`.+    * A later failure carries the last admitted enclosure and the live+      candidates, as `ProximityRefused`.+* Region valuation and curve measurement share one private radical-length+  owner. `Moonlight.Planar.Valuation`'s exports, error type and 128-bit+  published results are unchanged.+ ## 1.1.0.0 - 2026-09-23  * Require `moonlight-algebra >= 0.1.1`, the first release carrying the

@@ -320,9 +320,10 @@ are the editing interface.  This is a strong foundation, not a finished illustration language. The-[curve-authoring status](docs/curve-authoring-status.md) records the missing-measurement, offset, intersection, relational, repetition, and diagnostic-algebras required before making a broader readiness claim.+[curve-authoring status](docs/curve-authoring-status.md) records what the+measured and certified layer provides, its capability boundary, and the missing+offset, intersection, relational, repetition, and diagnostic algebras required+before making a broader readiness claim.  `Moonlight.Planar.Curve` separates relative steps from their absolute `Located` anchor. `curveStep` supplies a displacement and a shape made with

@@ -2,6 +2,8 @@  import qualified Moonlight.Planar.CurveBench as Curve import qualified Moonlight.Planar.AuthoringBench as Authoring+import qualified Moonlight.Planar.MeasureBench as Measure+import qualified Moonlight.Planar.RegionBench as Region  main :: IO ()-main = Curve.benchmarks >> Authoring.benchmarks+main = Curve.benchmarks >> Authoring.benchmarks >> Measure.benchmarks >> Region.benchmarks

@@ -0,0 +1,173 @@+-- | New-capability receipts for certified arc length. Preparation is timed+-- cold per family; inverse queries are timed against one prepared trail.+-- Every receipt is checked against the policy tolerance before it is printed.+module Moonlight.Planar.MeasureBench (benchmarks) where++import BenchMeasure (requireRight, timedProjection)+import Control.DeepSeq (NFData (..), force)+import Control.Exception (evaluate)+import Data.Foldable (traverse_)+import qualified Data.Sequence as Seq+import Moonlight.Planar.Curve+  ( ClosedTrail, CurveStep, Located, Subpath (..), closeWith, cubic, curveStep, ellipse+  , hermiteStep, line, locate, openTrail, rationalQuadratic, stepControlPoints )+import Moonlight.Planar.Curve.Measure+  ( ArcSample, Distance, MeasurePolicy, MeasuredTrail, distance, lengthBounds+  , lengthEnclosureLower, lengthEnclosureWidth, measurePolicy, measureSubpath, subdivisionBudget+  , measuredSpanPiece, measuredSpanStart, measuredSpans, pointAtLength, radicalPrecision+  , sampleResidual )+import Moonlight.Planar.Exact+  ( ExactRational, ExactVector (..), exactPoint, exactPointBitWidth, exactRational+  , exactRationalBitWidth, divideByPositive, positiveExact, positiveOne, ratioPositive )++data MeasureFamily+  = ExactCircle+  | SkewEllipse+  | HornSpans+  | CuspsAndOvershoot+  | ExtremeWeights+  deriving stock (Eq, Show)++data MeasureReceipt = MeasureReceipt+  { acceptedSpans :: !Int+  , maximumCoordinateBits :: !Int+  , enclosureWidth :: !ExactRational+  }+  deriving stock (Show)++instance NFData MeasureReceipt where+  rnf receipt = rnf (acceptedSpans receipt)+    `seq` rnf (maximumCoordinateBits receipt)+    `seq` rnf (enclosureWidth receipt)++data QueryReceipt = QueryReceipt+  { answeredQueries :: !Int+  , maximumResidual :: !ExactRational+  }+  deriving stock (Show)++instance Semigroup QueryReceipt where+  a <> b = QueryReceipt (answeredQueries a + answeredQueries b)+    (max (maximumResidual a) (maximumResidual b))++instance Monoid QueryReceipt where+  mempty = QueryReceipt 0 0++data StationOrder = Sorted | Unsorted+  deriving stock (Eq, Show)++benchmarks :: IO ()+benchmarks = do+  putStrLn "measure-benchmark: new capability; no baseline or speedup claim"+  putStrLn "measure-benchmark: tolerance=1/1000 absolute; max-depth=32; max-leaves=65536 per subpath; radical-precision=128; max-bits=16384"+  putStrLn "measure-benchmark: elapsed includes full output forcing; process max-live is cumulative"+  tolerance <- requireRight (exactRational 1 1000)+  policy <- benchmarkPolicy tolerance+  traverse_ (prepareFamily tolerance policy)+    [ExactCircle, SkewEllipse, HornSpans, CuspsAndOvershoot, ExtremeWeights]+  prepared <- geometry SkewEllipse >>= requireRight . measureSubpath policy >>= evaluate . force+  traverse_ (uncurry (queryStations tolerance prepared))+    [(count, order) | count <- [1, 64, 1024], order <- [Sorted, Unsorted]]+  endToEnd tolerance policy++benchmarkPolicy :: ExactRational -> IO MeasurePolicy+benchmarkPolicy tolerance = do+  admitted <- requireRight (positiveExact tolerance)+  precision <- requireRight (radicalPrecision 128)+  measurePolicy admitted precision <$> requireRight (subdivisionBudget 32 65536 16384)++prepareFamily :: ExactRational -> MeasurePolicy -> MeasureFamily -> IO ()+prepareFamily tolerance policy family = do+  source <- geometry family >>= evaluate . force+  measured <- timedProjection ("measure-" <> show family <> "-prepare") observe+    (requireRight (measureSubpath policy source))+  let receipt = observe measured+  putStrLn ("measure-" <> show family <> "-receipt: " <> show receipt)+  withinTolerance ("measure width for " <> show family) tolerance (enclosureWidth receipt)++-- One prepared trail answers every query and no query reuses another's work,+-- so sorted and unsorted stations exercise the same per-query path.+queryStations :: ExactRational -> MeasuredTrail -> Int -> StationOrder -> IO ()+queryStations tolerance prepared count order = do+  targets <- stations count order prepared >>= evaluate . force+  let label = "measure-query-" <> show count <> "-" <> show order+  samples <- timedProjection label (fmap sampleResidual)+    (requireRight (traverse (`pointAtLength` prepared) targets))+  reportQueries label tolerance samples++endToEnd :: ExactRational -> MeasurePolicy -> IO ()+endToEnd tolerance policy = do+  source <- geometry SkewEllipse >>= evaluate . force+  samples <- timedProjection "measure-prepare-and-query-64" (fmap sampleResidual)+    (do+      prepared <- requireRight (measureSubpath policy source)+      targets <- stations 64 Sorted prepared+      requireRight (traverse (`pointAtLength` prepared) targets))+  reportQueries "measure-prepare-and-query-64" tolerance samples++reportQueries :: String -> ExactRational -> [ArcSample] -> IO ()+reportQueries label tolerance samples = do+  let receipt = foldMap (QueryReceipt 1 . sampleResidual) samples+  putStrLn (label <> "-receipt: " <> show receipt)+  withinTolerance ("query residual for " <> label) tolerance (maximumResidual receipt)++-- Equally spaced distances over the certified lower length. The unsorted+-- order visits them by the stride 37, coprime to every benchmarked count.+stations :: Int -> StationOrder -> MeasuredTrail -> IO [Distance]+stations count order prepared = do+  divisor <- requireRight (positiveExact (fromIntegral count))+  let station :: Int -> ExactRational+      station index = divideByPositive (total * fromIntegral index) divisor+  requireRight (traverse (distance . station) (ordered [0 .. count - 1]))+ where+  total = lengthEnclosureLower (lengthBounds prepared)+  ordered = case order of+    Sorted -> id+    Unsorted -> fmap (\index -> index * 37 `mod` count)++observe :: MeasuredTrail -> MeasureReceipt+observe measured = MeasureReceipt+  (Seq.length (measuredSpans measured))+  (foldr (max . coordinateBits) 0 (measuredSpans measured))+  (lengthEnclosureWidth (lengthBounds measured))+ where+  -- Located starts and controls only; S5 replaces this with the shared+  -- span-bit observer.+  coordinateBits spanValue = foldr (max . vectorBits)+    (exactPointBitWidth (measuredSpanStart spanValue)) (stepControlPoints (measuredSpanPiece spanValue))+  vectorBits (ExactVector x y) = max (exactRationalBitWidth x) (exactRationalBitWidth y)++withinTolerance :: String -> ExactRational -> ExactRational -> IO ()+withinTolerance label tolerance value+  | value <= tolerance = pure ()+  | otherwise = fail (label <> " exceeds tolerance: " <> show value)++geometry :: MeasureFamily -> IO Subpath+geometry ExactCircle = pure (ClosedSubpath (ellipse (ExactVector 40 0) (ExactVector 0 40)))+geometry SkewEllipse = pure (ClosedSubpath (ellipse (ExactVector 70 15) (ExactVector (-12) 28)))+geometry HornSpans = pure (ClosedSubpath horn)+geometry CuspsAndOvershoot = pure (openSubpath pathologicalSteps)+geometry ExtremeWeights = do+  large <- requireRight (positiveExact 1000)+  huge <- requireRight (positiveExact 1000000)+  let small = ratioPositive positiveOne large+      conic u v = curveStep (rationalQuadratic (ExactVector 5 (-3)) u v) (ExactVector 2 7)+  pure (openSubpath [conic small large, conic large small, conic large huge])++openSubpath :: [CurveStep] -> Subpath+openSubpath = OpenSubpath . locate (exactPoint 0 0) . openTrail . Seq.fromList++horn :: Located ClosedTrail+horn = locate (exactPoint 0 0) (closeWith line (openTrail (Seq.fromList+  [ hermiteStep (ExactVector 28 (-50)) (ExactVector 15 (-65)) (ExactVector 40 (-30))+  , hermiteStep (ExactVector 22 (-30)) (ExactVector 40 (-30)) (ExactVector 8 (-35))+  , hermiteStep (ExactVector (-32) 35) (ExactVector (-45) 10) (ExactVector (-35) 25)+  , hermiteStep (ExactVector (-18) 45) (ExactVector (-35) 25) (ExactVector (-8) 60)+  ])))++pathologicalSteps :: [CurveStep]+pathologicalSteps =+  [ curveStep (cubic (ExactVector 60 80) (ExactVector (-60) 80)) (ExactVector 0 0)+  , curveStep (cubic (ExactVector 100 0) (ExactVector (-100) 0)) (ExactVector 1 0)+  , curveStep (cubic (ExactVector 1 80) (ExactVector (-1) (-80))) (ExactVector 2 0)+  ]

@@ -0,0 +1,114 @@+-- | New-capability receipts for certified curve topology and proximity on the+-- illustration study's own contours. Certification, plain lowering of the+-- same contours, and the certified lowering that runs both and checks the+-- lowered loops are timed separately, so the certificate's cost reads apart+-- from the lowering's.+module Moonlight.Planar.RegionBench (benchmarks) where++import BenchMeasure (requireRight, timedProjection)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.Foldable (traverse_)+import qualified Data.Sequence as Seq+import Moonlight.Planar.Affine (identityAffine2)+import Moonlight.Planar.Curve+  ( ClosedTrail, Located, Subpath (..), closedTrailSteps, locate, locatedValue, openTrail )+import Moonlight.Planar.Curve.Frame (exactTrailSite)+import Moonlight.Planar.Curve.Lowering (LoweringPolicy, loweredSpans, lowerClosedTrail, loweringPolicy)+import Moonlight.Planar.Curve.Measure+  ( MeasurePolicy, distance, lengthEnclosureLower, lengthEnclosureWidth, measurePolicy+  , radicalPrecision, sitePoint )+import Moonlight.Planar.Curve.Proximity+  ( ClearanceVerdict (..), ContactWitness (..), clearance, curveDistance, distanceBounds+  , distanceCandidates )+import Moonlight.Planar.Curve.Region+  ( CurveComponent (..), SubdivisionBudget, certifiedPieceCounts, certifySimpleRegion+  , lowerSimpleRegion, subdivisionBudget )+import Moonlight.Planar.Exact (exactRational, positiveExact, positiveOne, unitZero)+import Moonlight.Planar.Exhibit.IllustrationStudy (StudyPart (..), defaultControls, partContour)+import Moonlight.Planar.Region (planarRegionComponents, polygonHoleLoops)++data RegionFamily+  = BladeFuller+  | KnightMask+  deriving stock (Eq, Show)++benchmarks :: IO ()+benchmarks = do+  putStrLn "region-benchmark: new capability; no baseline or speedup claim"+  putStrLn "region-benchmark: lowering epsilon=1 identity metric, max-depth=20, max-leaves=8192; topology max-depth=12, max-pieces=4096, max-bits=4096"+  putStrLn "region-benchmark: certify = curve certificate alone; lower = plain lowering of the same contours; certified-lowering = both plus the lowered-loop check"+  lowering <- requireRight (loweringPolicy positiveOne identityAffine2 20 8192)+  topology <- requireRight (subdivisionBudget 12 4096 4096)+  traverse_ (benchmarkRegion lowering topology) [BladeFuller, KnightMask]+  putStrLn "proximity-benchmark: tolerance=1/100 absolute; radical-precision=64; max-depth=24, max-leaves=20000, max-bits=4096"+  measuring <- proximityPolicy+  hornBaseClearance measuring+  fullerDistance measuring++benchmarkRegion :: LoweringPolicy -> SubdivisionBudget -> RegionFamily -> IO ()+benchmarkRegion lowering topology family = do+  let label = "region-" <> show family+      components = region family+      contours = concatMap (\(CurveComponent outer holes) -> outer : holes) components+      pieces = map snd . certifiedPieceCounts+  _ <- evaluate (force contours)+  evidence <- timedProjection (label <> "-certify") pieces+    (requireRight (certifySimpleRegion topology components))+  putStrLn (label <> "-certify-receipt: pieces=" <> show (pieces evidence))+  lowered <- timedProjection (label <> "-lower") (fmap (length . loweredSpans))+    (requireRight (traverse (lowerClosedTrail lowering) contours))+  putStrLn (label <> "-lower-receipt: spans=" <> show (length . loweredSpans <$> lowered))+  (planar, paths, _) <- timedProjection (label <> "-certified-lowering")+    (\(planar, paths, certified) ->+        (length . polygonHoleLoops <$> planarRegionComponents planar, length . loweredSpans <$> paths, pieces certified))+    (requireRight (lowerSimpleRegion lowering topology components))+  putStrLn (label <> "-certified-lowering-receipt: holes=" <> show (length . polygonHoleLoops <$> planarRegionComponents planar)+    <> " spans=" <> show (length . loweredSpans <$> paths))++region :: RegionFamily -> [CurveComponent]+region BladeFuller = [CurveComponent (part Blade) [part Fuller]]+region KnightMask = [CurveComponent (part Mask) []]++part :: StudyPart -> Located ClosedTrail+part = partContour defaultControls++proximityPolicy :: IO MeasurePolicy+proximityPolicy = do+  tolerance <- requireRight (exactRational 1 100) >>= requireRight . positiveExact+  precision <- requireRight (radicalPrecision 64)+  measurePolicy tolerance precision <$> requireRight (subdivisionBudget 24 20000 4096)++-- The left horn's base, its closing step, against the mask curve at zero.+hornBaseClearance :: MeasurePolicy -> IO ()+hornBaseClearance measuring = do+  let contour = part LeftHorn+      source = ClosedSubpath contour+      steps = closedTrailSteps (locatedValue contour)+      closing = Seq.length steps - 1+  start <- requireRight (exactTrailSite source closing unitZero)+  base <- maybe (fail "left horn has no closing step") pure (Seq.lookup closing steps)+  zero <- requireRight (distance 0)+  subject <- evaluate (force (OpenSubpath (locate (sitePoint start) (openTrail (Seq.singleton base))), ClosedSubpath (part Mask)))+  verdict <- timedProjection "proximity-HornBase-clearance" id+    (requireRight (uncurry (clearance measuring zero) subject))+  putStrLn ("proximity-HornBase-clearance-receipt: " <> describe verdict)+ where+  describe :: ClearanceVerdict -> String+  describe verdict = case verdict of+    ClearanceHolds enclosure -> "holds lower=" <> show (lengthEnclosureLower enclosure)+    ClearanceViolated (CloserThan _ _) -> "violated closer-than"+    ClearanceViolated (SharedPoint _ _) -> "violated shared-point"+    ClearanceViolated TransversalCrossing {} -> "violated crossing"+    ClearanceUnresolved _ candidates obligation -> "unresolved " <> show obligation <> " candidates=" <> show (Seq.length candidates)++-- The fuller's distance from the blade within the tolerance.+fullerDistance :: MeasurePolicy -> IO ()+fullerDistance measuring = do+  subject <- evaluate (force (ClosedSubpath (part Fuller), ClosedSubpath (part Blade)))+  observation <- timedProjection "proximity-FullerBlade-distance" id+    (requireRight (uncurry (curveDistance measuring) subject))+  let enclosure = distanceBounds observation+  putStrLn ("proximity-FullerBlade-distance-receipt: lower=" <> show (lengthEnclosureLower enclosure)+    <> " width=" <> show (lengthEnclosureWidth enclosure)+    <> " candidates=" <> show (Seq.length (distanceCandidates observation)))

@@ -17,18 +17,23 @@  import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Sequence as Seq+import Data.Bifunctor (first) import Moonlight.Planar.Affine-  ( Affine2, AffineIso2, affine2, affineIso2, affineIsoMap, identityAffineIso2-  , translationAffineIso2 )+  ( Affine2, AffineIso2, affine2, affineIso2, affineIsoMap, composeAffineIso2+  , identityAffineIso2, translationAffineIso2 ) import Moonlight.Planar.Curve   ( ClosedTrail, Located, OpenTrail, Subpath (..), circle, ellipse, path   , locate, openTrail, curveStep, line, transformLocatedClosedTrail ) import Moonlight.Planar.Curve.Authoring   ( Knot (..), ProfileStation (..), bowedTrail, cardinalOpen, polygonTrail, profileOutline )+import Moonlight.Planar.Curve.Frame+  ( FrameError, FramePolicy, FrameSite (..), exactTrailSite, framePolicy+  , measuredFrameIso, regularFrame )+import Moonlight.Planar.Curve.Measure (RadicalPrecisionError, radicalPrecision) import Moonlight.Planar.Exact-  ( ExactPoint, ExactRational, ExactVector (..), PositiveExact, UnitInterval-  , exactHalf, exactThird, exactPoint, exactPointCoordinates, positiveOne-  , positiveTwo, unitHalf, unitOne, unitZero, unitIntervalValue+  ( ExactPoint, ExactRational, ExactVector (..), PositiveExact, ScalarRefinementError+  , UnitInterval, exactHalf, exactThird, exactPoint, exactPointCoordinates, positiveExact+  , positiveOne, positiveTwo, unitHalf, unitOne, unitZero, unitIntervalValue   , boundsMinimumX, boundsMaximumX, boundsMinimumY, boundsMaximumY ) import Moonlight.Planar.Illustration   ( Color (..), FillRule (..), GradientStop (..), LineCap (..), LineJoin (..)@@ -121,27 +126,38 @@ data BlossomPort = BlossomRoot   deriving stock (Eq, Ord, Show) -data GardenAttachmentError = SingularGardenSocket !ExactPoint !StemPort+-- | An authored socket matrix that collapses, a stem site with no regular+-- tangent frame, or a refused frame policy scalar.+data GardenAttachmentError+  = SingularGardenSocket !ExactPoint !StemPort+  | GardenFrameRefused !ExactPoint !StemPort !FrameError+  | GardenFramePrecisionRefused !RadicalPrecisionError+  | GardenFrameToleranceRefused !ScalarRefinementError   deriving stock (Eq, Show)  -- An authored heterogeneous assembly, not a generic connection graph. Each--- child retains its ports until the final ordered painting projection.+-- child retains its ports until the final ordered painting projection. The+-- stem trail is the one curve the stem paints and its sockets read. data GardenPlant = GardenPlant-  { gardenStem :: !(Motif StemPort GardenPart)+  { gardenStemTrail :: !(Located OpenTrail)+  , gardenStem :: !(Motif StemPort GardenPart)   , gardenLowerLeaf :: !(Motif LeafPort GardenPart)   , gardenUpperLeaf :: !(Motif LeafPort GardenPart)   , gardenBlossom :: !(Motif BlossomPort GardenPart)   }  gardenPlants :: GardenControls -> Either GardenAttachmentError [GardenPlant]-gardenPlants controls = traverse assemble plants+gardenPlants controls = do+  policy <- stemFramePolicy+  traverse (assemble policy) plants  where   leaf :: Motif LeafPort GardenPart   leaf = leafMotif 24 (gardenBreeze controls)-  assemble :: Plant -> Either GardenAttachmentError GardenPlant-  assemble plant = do-    stem <- stemMotif controls plant-    pure (GardenPlant stem+  assemble :: FramePolicy -> Plant -> Either GardenAttachmentError GardenPlant+  assemble policy plant = do+    let trail = stemTrail controls plant+    stem <- stemMotif policy trail plant+    pure (GardenPlant trail stem       (attachMotif LeafRoot (motifPort stem LowerLeafSocket) leaf)       (attachMotif LeafRoot (motifPort stem UpperLeafSocket) leaf)       (attachMotif BlossomRoot (motifPort stem BlossomSocket)@@ -160,8 +176,8 @@     <> annotate Ribbon ribbon     <> annotate Fireflies fireflies --- The origin, two interpolated leaf attachments and flower center are the--- same values in stem and leaf authoring: no placement by sample index.+-- | Breeze bends the stem by moving its interpolated knots. This authors the+-- knots only; sockets read the stem trail itself, never this formula. stemStation :: GardenControls -> Plant -> ExactRational -> ExactPoint stemStation controls plant t =   let (rx, ry) = exactPointCoordinates (plantRoot plant)@@ -169,35 +185,56 @@       sway = 86 * (2 * unitIntervalValue (gardenBreeze controls) - 1)    in exactPoint (rx + t * (fx - rx) + 4 * t * (1 - t) * sway) (ry + t * (fy - ry)) -plantStem :: GardenControls -> Plant -> Picture GardenPart-plantStem controls plant =-  let stem = cardinalOpen unitHalf $ Interpolating (plantRoot plant) :|-        (Interpolating . stemStation controls plant <$> [exactThird, 2 * exactThird, 1])-   in ink positiveTwo (RGB 26 73 72) stem-        <> ink positiveOne (RGB 100 148 116) stem+-- | The root, two leaf knots and the flower, interpolated once. Knot @k@ is+-- the start of step @k@; the flower is the trail's end.+stemTrail :: GardenControls -> Plant -> Located OpenTrail+stemTrail controls plant = cardinalOpen unitHalf $ Interpolating (plantRoot plant) :|+  (Interpolating . stemStation controls plant <$> [exactThird, 2 * exactThird, 1]) -stemMotif :: GardenControls -> Plant -> Either GardenAttachmentError (Motif StemPort GardenPart)-stemMotif controls plant = do-  lower <- admit LowerLeafSocket (leafSocket exactThird (-1) 1)-  upper <- admit UpperLeafSocket (leafSocket (2 * exactThird) 1 (1 - exactThird))+-- | Leaf frames are normalized to within 2^-20 of unit scale, so the authored+-- leaf size survives the tangent frame.+stemFramePolicy :: Either GardenAttachmentError FramePolicy+stemFramePolicy = framePolicy+  <$> first GardenFramePrecisionRefused (radicalPrecision 32)+  <*> first GardenFrameToleranceRefused (positiveExact (exactHalf ^ (20 :: Int)))++plantStem :: Located OpenTrail -> Picture GardenPart+plantStem stem = ink positiveTwo (RGB 26 73 72) stem <> ink positiveOne (RGB 100 148 116) stem++-- | Leaf sockets keep their authored knots and take the stem's tangent frame+-- there; side and size are an authored lean relative to that tangent. The+-- blossom socket keeps its authored tilt at the flower, the trail's end.+stemMotif+  :: FramePolicy -> Located OpenTrail -> Plant+  -> Either GardenAttachmentError (Motif StemPort GardenPart)+stemMotif policy stem plant = do+  lower <- leafSocket LowerLeafSocket 1 (-1) 1+  upper <- leafSocket UpperLeafSocket 2 1 (1 - exactThird)   flower <- admit BlossomSocket $ affine2     (ExactVector (plantScale plant) (plantTilt plant * plantScale plant * exactHalf))     (ExactVector 0 (plantScale plant * (1 - exactHalf ^ (3 :: Int))))     (pointVector (plantFlower plant))-  pure $ motif (plantStem controls plant) $ \port -> case port of+  pure $ motif (plantStem stem) $ \port -> case port of     LowerLeafSocket -> lower     UpperLeafSocket -> upper     BlossomSocket -> flower  where   admit :: StemPort -> Affine2 -> Either GardenAttachmentError AffineIso2   admit port = maybe (Left (SingularGardenSocket (plantRoot plant) port)) Right . affineIso2-  leafSocket :: ExactRational -> ExactRational -> ExactRational -> Affine2-  leafSocket t side size =+  -- The quarter-turn taking the leaf's forward axis, local -y, onto the+  -- frame's tangent, followed by the lean: on an upright stem this is the+  -- former world-axis socket matrix.+  leafSocket :: StemPort -> Int -> ExactRational -> ExactRational -> Either GardenAttachmentError AffineIso2+  leafSocket port knot side size = do     let scale = size * (exactHalf + plantScale plant * exactHalf)-     in affine2-          (ExactVector (scale * exactHalf) (side * scale))-          (ExactVector (negate side * scale) (scale * exactHalf))-          (pointVector (stemStation controls plant t))+        refused = GardenFrameRefused (plantRoot plant) port+    lean <- admit port $ affine2+      (ExactVector (negate side * scale) (scale * exactHalf))+      (ExactVector (negate scale * exactHalf) (negate side * scale))+      (ExactVector 0 0)+    site <- first refused (exactTrailSite (OpenSubpath stem) knot unitZero)+    frame <- first refused (regularFrame policy (ExactSite site))+    pure (composeAffineIso2 (measuredFrameIso frame) lean)  leafMotif :: ExactRational -> UnitInterval -> Motif LeafPort GardenPart leafMotif width breeze = motif picture (const identityAffineIso2)

@@ -6,9 +6,15 @@   , overchargedSpaceSwordControls   , SpaceSwordPart (..)   , spaceSwordPartName+  , SpaceSwordError (..)   , spaceSwordPicture+  , channelStations+  , channelCenterline+  , runeMeasurePolicy+  , runeFrames   ) where +import Data.Bifunctor (first) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Sequence as Seq import Moonlight.Planar.Affine@@ -18,10 +24,16 @@ import Moonlight.Planar.Curve.Authoring   ( Knot (Interpolating), ProfileStation (..), bowedTrail, cardinalOpen   , polygonTrail, profileOutline )+import Moonlight.Planar.Curve.Frame+  ( FrameError, FramePolicy, FrameSite (..), MeasuredFrame, RunError, fractionRun+  , framePolicy, measuredFrameIso, regularFrame, sampleRun )+import Moonlight.Planar.Curve.Measure+  ( MeasureError, MeasurePolicy, RadicalPrecisionError, SubdivisionBudgetError+  , measurePolicy, measureSubpath, radicalPrecision, subdivisionBudget ) import Moonlight.Planar.Exact-  ( ExactPoint, ExactRational, ExactVector (..), PositiveExact, UnitInterval-  , exactHalf, exactPoint, exactPointCoordinates, exactThird, positiveOne, positiveTwo-  , unitHalf, unitOne, unitZero, unitIntervalValue )+  ( ExactPoint, ExactRational, ExactVector (..), PositiveExact, ScalarRefinementError+  , UnitInterval, divideByPositive, exactHalf, exactPoint, exactPointCoordinates, exactThird, positiveExact+  , positiveOne, positiveTwo, unitHalf, unitInterval, unitOne, unitZero, unitIntervalValue ) import Moonlight.Planar.Illustration   ( Color (..), FillRule (..), GradientStop (..), LineCap (..), LineJoin (..)   , Paint (..), Picture, StrokeStyle (..), StrokeUnits (..), annotate, clip@@ -74,23 +86,34 @@  data HiltPort = BladeSocket -spaceSwordPicture :: SpaceSwordControls -> Picture SpaceSwordPart-spaceSwordPicture controls =-  annotate VoidField voidField-    <> annotate NebulaVeil nebulaVeil-    <> swordAssembly controls+-- | A refused authored scalar or policy, an unmeasured centerline, or a rune+-- station without a regular frame.+data SpaceSwordError+  = SwordPrecisionRefused !RadicalPrecisionError+  | SwordScalarRefused !ScalarRefinementError+  | SwordMeasurePolicyRefused !SubdivisionBudgetError+  | SwordRunRefused !RunError+  | SwordMeasureRefused !MeasureError+  | SwordFrameRefused !FrameError+  deriving stock (Eq, Show) +spaceSwordPicture :: SpaceSwordControls -> Either SpaceSwordError (Picture SpaceSwordPart)+spaceSwordPicture controls = do+  assembly <- swordAssembly controls+  pure (annotate VoidField voidField <> annotate NebulaVeil nebulaVeil <> assembly)+ -- | Blade and hilt are attached in their authoring frame, then the complete -- assembly receives one affine action. Geometry, clips, paint and ornament -- therefore cannot drift apart when the weapon is posed.-swordAssembly :: SpaceSwordControls -> Picture SpaceSwordPart-swordAssembly controls =+swordAssembly :: SpaceSwordControls -> Either SpaceSwordError (Picture SpaceSwordPart)+swordAssembly controls = do+  bladeValue <- bladeMotif controls   let hilt = hiltMotif-      blade = attachMotif BladeRoot (motifPort hilt BladeSocket) (bladeMotif controls)+      blade = attachMotif BladeRoot (motifPort hilt BladeSocket) bladeValue       assembled = annotate IonWake (ionWake controls)         <> motifPicture blade         <> motifPicture hilt-   in place swordPose assembled+  pure (place swordPose assembled)  -- | A similarity pose: orthogonal columns of equal squared length. The socket -- at @(604,745)@ lands at @(350,710)@, sending the blade toward the upper right.@@ -102,15 +125,17 @@  where   threeQuarters = exactHalf + exactHalf * exactHalf -bladeMotif :: SpaceSwordControls -> Motif BladePort SpaceSwordPart-bladeMotif controls = motif picture port+bladeMotif :: SpaceSwordControls -> Either SpaceSwordError (Motif BladePort SpaceSwordPart)+bladeMotif controls = do+  runes <- runeColumn controls+  pure (motif (picture runes) port)  where   charge = unitIntervalValue (bladeCharge controls)   sweep = bladeSweep controls   aura = bladeProfile (42 + 6 * charge) sweep   shell = bladeProfile 34 sweep-  channel = channelProfile charge sweep-  picture = annotate BladeAura+  channel = profileOutline channelTension (channelStations charge sweep)+  picture runes = annotate BladeAura       (opacity unitHalf (fill NonZero (Solid (RGB 27 118 151)) (aura :| [])))     <> annotate BladeShell       (fill NonZero shellPaint (shell :| [])@@ -120,7 +145,7 @@     <> annotate BladeCore       (fill NonZero corePaint (channel :| [])         <> outline (RGB 128 232 215) channel)-    <> annotate BladeRunes (runeColumn controls)+    <> annotate BladeRunes runes   port selected = case selected of     BladeRoot -> identityAffineIso2     BladeTip -> translationAffineIso2 (ExactVector sweep (-625))@@ -139,8 +164,10 @@   , ProfileStation (exactPoint sweep (-625)) (ExactVector 0 0)   ] -channelProfile :: ExactRational -> ExactRational -> Located ClosedTrail-channelProfile charge sweep = profileOutline unitHalf $+-- | The channel's author-owned stations, factored once: its painted outline+-- and its unpainted centerline are both derived from them at one tension.+channelStations :: ExactRational -> ExactRational -> NonEmpty ProfileStation+channelStations charge sweep =   ProfileStation (exactPoint 8 (-28)) (ExactVector (4 + 2 * charge) 0) :|   [ ProfileStation (exactPoint 12 (-145)) (ExactVector (5 + 2 * charge) 0)   , ProfileStation (exactPoint 19 (-315)) (ExactVector (6 + 2 * charge) 0)@@ -148,6 +175,16 @@   , ProfileStation (exactPoint sweep (-579)) (ExactVector 0 0)   ] +channelTension :: UnitInterval+channelTension = unitHalf++-- | The exact midpoint of the channel's two rails: cardinal interpolation is+-- affine-linear in its knots, so interpolating the station centers at the+-- rails' tension is their average. Charge moves only half-spans, not this.+channelCenterline :: ExactRational -> ExactRational -> Located OpenTrail+channelCenterline charge sweep = cardinalOpen channelTension+  ((\(ProfileStation center _) -> Interpolating center) <$> channelStations charge sweep)+ bladeSpineFacet :: ExactRational -> Picture SpaceSwordPart bladeSpineFacet sweep = fill NonZero (Solid (RGB 8 18 30)) $   polygonTrail (exactPoint (-34) 0 :|@@ -180,26 +217,49 @@     , exactPoint 31 (-386)     ]) :| [] -runeColumn :: SpaceSwordControls -> Picture SpaceSwordPart-runeColumn controls = foldMap placeRune runeStations+-- | Three runes evenly spaced by arc length over the middle three fifths of+-- the channel centerline, each attached to the tangent frame at its station.+runeColumn :: SpaceSwordControls -> Either SpaceSwordError (Picture SpaceSwordPart)+runeColumn controls = foldMap attached <$> runeFrames controls  where-  charge = unitIntervalValue (bladeCharge controls)-  sweep = bladeSweep controls-  rune = runeMotif charge-  placeRune :: (ExactRational, ExactRational) -> Picture SpaceSwordPart-  placeRune (x,y) = motifPicture $-    attachMotif RuneRoot (translationAffineIso2 (ExactVector x y)) rune-  runeStations :: [(ExactRational, ExactRational)]-  runeStations = [(12,-136),(21,-322),(sweep-6,-474)]+  rune = runeMotif (unitIntervalValue (bladeCharge controls))+  attached :: MeasuredFrame -> Picture SpaceSwordPart+  attached frame = motifPicture (attachMotif RuneRoot (measuredFrameIso frame) rune) +-- | Arc-length tolerance of an eighth of a unit; frames within 2^-20 of unit.+runeMeasurePolicy :: Either SpaceSwordError (MeasurePolicy, FramePolicy)+runeMeasurePolicy = do+  precision <- first SwordPrecisionRefused (radicalPrecision 32)+  tolerance <- first SwordScalarRefused (positiveExact (exactHalf ^ (3 :: Int)))+  deficit <- first SwordScalarRefused (positiveExact (exactHalf ^ (20 :: Int)))+  budget <- first SwordMeasurePolicyRefused (subdivisionBudget 24 4096 4096)+  pure (measurePolicy tolerance precision budget, framePolicy precision deficit)++-- | The rune stations in run order: an even run of three over fractions 1/5+-- to 4/5 of the measured centerline, framed where the centerline passes.+runeFrames :: SpaceSwordControls -> Either SpaceSwordError (NonEmpty MeasuredFrame)+runeFrames controls = do+  (measuring, framing) <- runeMeasurePolicy+  five <- first SwordScalarRefused (positiveExact 5)+  firstStation <- first SwordScalarRefused (unitInterval (divideByPositive 1 five))+  finalStation <- first SwordScalarRefused (unitInterval (divideByPositive 4 five))+  run <- first SwordRunRefused (fractionRun 3 firstStation finalStation)+  measured <- first SwordMeasureRefused (measureSubpath measuring (OpenSubpath centerline))+  samples <- first SwordRunRefused (sampleRun run measured)+  first SwordFrameRefused (traverse (regularFrame framing . SampledSite) samples)+ where+  centerline = channelCenterline (unitIntervalValue (bladeCharge controls)) (bladeSweep controls)++-- | A diamond authored in its station's frame: its forward tip on local +x,+-- the tangent, and its narrow axis on local +y, the left normal. runeMotif :: ExactRational -> Motif RunePort SpaceSwordPart runeMotif charge = motif picture (const identityAffineIso2)  where   size = 5 + 2 * charge-  rune = polygonTrail (exactPoint 0 (negate size) :|-    [ exactPoint (size * exactHalf) 0-    , exactPoint 0 size-    , exactPoint (negate (size * exactHalf)) 0+  rune = polygonTrail (exactPoint size 0 :|+    [ exactPoint 0 (size * exactHalf)+    , exactPoint (negate size) 0+    , exactPoint 0 (negate (size * exactHalf))     ])   picture :: Picture SpaceSwordPart   picture = opacity unitHalf (fill NonZero (Solid (RGB 108 221 202)) (rune :| []))

@@ -0,0 +1,130 @@+# Curve authoring: present boundary and missing algebra++Moonlight Planar has a credible curve core and, since 1.2.0.0, a measured and+certified layer over it. It does **not** yet have a mature+illustration-authoring system. The distinction matters: eliminating hand-traced+Bezier handles and measuring curves honestly is a useful foundation, not+evidence that an agent can reliably author a complete illustration.++## What exists now++The current source of truth is `Moonlight.Planar.Curve`:++- exact relative line, quadratic, cubic, and rational-quadratic steps;+- located open and closed trails with composition, reversal, and affine action;+- exact evaluation, exact subdivision at any `UnitInterval` (`splitStep`),+  restriction to a parameter span (`restrictStep`), value and derivative jets+  at any parameter (`jetStep`), and join classification;+- rational conics for circles and ellipses.++Over that core, each layer below descends to the canonical curve and returns+an observation, never a second copy of the geometry.++- `Moonlight.Planar.Curve.Measure` gives certified arc length as an immutable+  `MeasuredTrail`. Inverse queries (`pointAtLength`, `pointAtFraction`) return+  a site on its source step with a certified parameter bracket. Every+  approximation is enclosed within a stated tolerance, and an exhausted budget+  refuses with the step, the bracket and the obligation.+- `Moonlight.Planar.Curve.Frame` gives approximately unit tangent frames at a+  sampled or exact site. They are exactly orthogonal, carry their certified+  scale bound, and refuse corners and stationary tangents rather than invent a+  direction. `fractionRun` and `sampleRun` place evenly spaced runs by arc+  fraction. The garden leaves and the sword runes are placed this way.+- `Moonlight.Planar.Curve.Proximity` gives bounded distance and strict+  clearance between two curves. Several nearest candidates stay several.+  Contact is witnessed only by exact sites closer than the threshold, an exact+  shared site, or a certified transversal crossing, which carries no point.+- `Moonlight.Planar.Curve.Region.lowerSimpleRegion` lowers outer and hole+  curves to a polygon region only after certifying that the region's+  components, holes and nesting are the curves' own. That domain is four+  predicates within a finite subdivision budget: monotone pieces;+  wedge-separated joints; non-adjacent pieces hull-separated or certified not+  to cross; and lowered loops that nest as the curves do. Outside the domain it+  refuses with a typed obstruction naming the contour spans.++`Moonlight.Planar.Curve.Authoring` adds semantic constructors for cardinal+landmarks, transverse profiles, polygons, and quadratic bows. These constructors+immediately produce the canonical curve representation; they do not retain a+second spline language. `Moonlight.Planar.Illustration` then supplies ordered+paint, typed motif ports, affine placement, geometric layout, and SVG+publication.++The illustration study's acceptance tests use this layer for the two+inequality relations its painting depends on. The fuller is certified strictly+inside the blade, and the horn bases inside the mask, at the default controls+and at the edited bounds the tests name. Those are checks at tested control+values, not whole-range proofs.++## What is still absent++| Missing capability | Why illustration authors need it |+| --- | --- |+| Named differential observations | Jets and tangent frames exist at any parameter or measured distance. Curvature, its extrema and inflections are not offered as observations; an author would derive them from the jet by hand. |+| Point projection and snapping | Distance and clearance are between two curves. There is no dedicated query projecting a free point onto a curve and returning its parameter, and no exhibit snaps a port to a contour: garden sockets are stem knots by construction. |+| Derived outlines | `profileOutline` is a transverse ribbon, not a constant-distance offset. General offsets, fillets, chamfers, geometric stroke outlines, caps, and joins are missing. General Bezier offsets are not rational curves, so this work requires explicit approximation receipts rather than counterfeit exactness. See the capability boundary below. |+| Curve intersection and arrangement | Crossings are certified, never constructed: a crossing point of two rational curves is algebraic in general (the unit circle meets y = x at an irrational point). The library does not node curve-curve intersections, split self-intersections, build a curve arrangement, or perform Boolean fill directly on curves. Tangencies inside a step, rather than at a step endpoint, stay unresolved. |+| Relational authoring | There is no closed algebra for coincidence, parallelism, symmetry, equal length, tangent attachment, or shared proportional dimensions. Every equality relation the exhibits use is constructive, a pure function of shared controls; bounded clearance and containment are checks, not constraints a solver satisfies. |+| Path-directed repetition | Motifs can be placed by arc fraction and aligned to measured frames. They cannot yet be alternated by a typed pattern, spaced by an absolute pitch with a remainder policy, or deformed along a host path. |+| Visual feedback | Topology and proximity refusals name source spans and obligations, but diagnostics still draw controls and part labels, not curvature extrema, crossings, clearance failures, approximation hot spots, or constraint residuals. The system can preserve a bad composition perfectly. |+| Publication parity | SVG is the canonical publication output, but raster-preview behavior is not owned or tested across renderers. A preview conversion can therefore lie about gradients or opacity even when the SVG is correct. |++## Capability boundary (2026-09-23)++The higher-curve plan+(`docs/implementation/plans/foundation/moonlight-planar/higher-curve-algebra-20260923.md`)+ended its outline and relation stage with a recorded boundary, not an+implementation. The exhibits justify bounded inequality checks, which landed+with proximity and certified topology. They justify neither an outline engine+nor an equality solver.++- No outline type exists. Offsets are not claimed to be implemented, nor+  universally impossible; they wait for a real consumer and an approximation+  and topology contract set from the certified domain above.+- The paint cap and join vocabulary stays at the illustration boundary.+- Exact curve Booleans need an algebraic-number representation for+  intersection points. That is a separate design decision, not a small+  extension of `ExactPoint`.+- A relation solver, if one is ever earned, must distinguish inconsistent,+  underdetermined, ambiguous, and budget-exhausted outcomes, and satisfy+  declared residual bounds.++## Required direction++Measurement, frames, distance-directed placement, proximity, and certified+simple-region topology have landed. The next work should extend the canonical+algebra in this order:++1. named differential observations (curvature, extrema) and point projection,+   each with a real consumer;+2. diagnostics that draw the certified obstructions, candidates and+   approximation hot spots the observations already return;+3. curve noding and arrangement receipts over an explicit algebraic+   representation, connecting curve topology to the existing exact region+   owner beyond the simple-region domain;+4. offset and stroke-outline construction with honest error and topology+   witnesses;+5. a pure relational authoring language whose solver either returns a checked+   construction or a typed refusal.++Each layer must descend to `Moonlight.Planar.Curve` or an existing exact planar+owner. None should introduce a mutable builder, stringly path registry, second+evaluator, cached shadow geometry, or SVG-as-source editing model.++## Standard for claiming readiness++Curve authoring is not illustration-ready merely because an example can be+rendered. A credible readiness claim requires all of the following:++- an agent can place and repeat motifs by geometric relations rather than copied+  coordinates;+- edits preserve declared attachment, continuity, spacing, and topology laws;+- unavoidable approximations carry bounds and refuse exhausted budgets;+- diagnostics identify geometric failure rather than merely drawing controls;+- a small corpus of complete illustrations survives semantic edits without+  hand repair or raster tracing.++The third item is now met for measurement, frames, proximity and region+topology. The others are not. Until they are, Moonlight Planar should be+described as a strong exact curve foundation with measured, certified+authoring primitives, and a long way to go before it is a dependable+full-illustration language.

@@ -42,6 +42,8 @@   let gardenEdited = defaultGardenControls { blossomOpening = unitOne, gardenBreeze = unitOne }   garden <- first show (gardenPicture defaultGardenControls)   editedGarden <- first show (gardenPicture gardenEdited)+  sword <- first show (spaceSwordPicture defaultSpaceSwordControls)+  overchargedSword <- first show (spaceSwordPicture overchargedSpaceSwordControls)   traverse (\(name, rendered) -> (name,) <$> first show rendered)     [ ("knight-crescent.svg", renderSvg partName options (studyPicture defaultControls))     , ("knight-crescent-edited.svg", renderSvg partName options (studyPicture edited))@@ -51,8 +53,6 @@     , ("equational-garden-diagnostic.svg", renderDiagnosticSvg gardenPartName options garden)     , ("equational-garden-layout.svg", renderSvg gardenPartName options (gardenLayoutPicture unitZero))     , ("equational-garden-layout-edited.svg", renderSvg gardenPartName options (gardenLayoutPicture unitOne))-    , ("space-sword.svg", renderSvg spaceSwordPartName options-        (spaceSwordPicture defaultSpaceSwordControls))-    , ("space-sword-overcharged.svg", renderSvg spaceSwordPartName options-        (spaceSwordPicture overchargedSpaceSwordControls))+    , ("space-sword.svg", renderSvg spaceSwordPartName options sword)+    , ("space-sword-overcharged.svg", renderSvg spaceSwordPartName options overchargedSword)     ]

@@ -1,6 +1,6 @@ cabal-version:       3.4 name:                moonlight-planar-version:             1.1.0.0+version:             1.2.0.0 synopsis:            Native hex regions, Delaunay meshes, and exact planar algebra. description:         Native packed hexagonal cell regions and Delaunay and                      constrained Delaunay triangulation as lawful@@ -47,6 +47,7 @@   README.md   CHANGELOG.md   docs/README.md+  docs/curve-authoring-status.md   docs/development.md   docs/activation-zigzag.md   docs/regular-site-algebra.md@@ -123,7 +124,7 @@ source-repository this   type:     git   location: https://github.com/PaleRoses/moonlight.git-  tag:      moonlight-planar-1.1.0.0+  tag:      moonlight-planar-1.2.0.0   subdir:   moonlight-planar  flag warnings-as-errors@@ -237,6 +238,9 @@     Moonlight.Planar.Curve     Moonlight.Planar.Curve.Authoring     Moonlight.Planar.Curve.Lowering+    Moonlight.Planar.Curve.Measure+    Moonlight.Planar.Curve.Frame+    Moonlight.Planar.Curve.Proximity     Moonlight.Planar.Curve.Region     Moonlight.Planar.Affine     Moonlight.Planar.Convex@@ -269,12 +273,17 @@     Moonlight.Planar.Internal.Region.Publication     Moonlight.Planar.Internal.Region.Types     Moonlight.Planar.Internal.Region.Bounds+    Moonlight.Planar.Internal.Region.Loop     Moonlight.Planar.Internal.Predicates     Moonlight.Planar.Internal.SegmentRelation     Moonlight.Planar.Internal.Types     Moonlight.Planar.Internal.Representation     Moonlight.Planar.Internal.PointIndex     Moonlight.Planar.Internal.Tournament+    Moonlight.Planar.Internal.Length+    Moonlight.Planar.Internal.CurveSource+    Moonlight.Planar.Internal.CurveBudget+    Moonlight.Planar.Internal.CurveCertificate   other-modules:     Moonlight.Planar.Internal.Exact   build-depends:@@ -305,6 +314,9 @@     , Moonlight.Planar.Curve     , Moonlight.Planar.Curve.Authoring     , Moonlight.Planar.Curve.Lowering+    , Moonlight.Planar.Curve.Measure+    , Moonlight.Planar.Curve.Frame+    , Moonlight.Planar.Curve.Proximity     , Moonlight.Planar.Curve.Region     , Moonlight.Planar.Affine     , Moonlight.Planar.Convex@@ -1019,6 +1031,11 @@     test/support   other-modules:     Moonlight.Planar.CurveSpec+    Moonlight.Planar.CurveMeasureSpec+    Moonlight.Planar.CurveSourceSpec+    Moonlight.Planar.CurveFrameSpec+    Moonlight.Planar.CurveCertificateSpec+    Moonlight.Planar.CurveProximitySpec     Moonlight.Planar.Curve.AuthoringSpec     Moonlight.Planar.AffineSpec     Moonlight.Planar.CurveLoweringSpec@@ -1027,7 +1044,9 @@     Support   build-depends:     containers >= 0.8 && < 0.9+    , moonlight-planar:core     , moonlight-planar:dcel+    , moonlight-planar:dcel-internal  test-suite moonlight-planar-illustration-test   import: triangulation-test-properties@@ -1721,10 +1740,14 @@   hs-source-dirs:     bench/curve     bench/support+    docs/art-common   other-modules:     BenchMeasure     Moonlight.Planar.CurveBench     Moonlight.Planar.AuthoringBench+    Moonlight.Planar.MeasureBench+    Moonlight.Planar.RegionBench+    Moonlight.Planar.Exhibit.IllustrationStudy   ghc-options: -O2 -rtsopts "-with-rtsopts=-T"   build-depends:     base >= 4.19 && < 5

@@ -36,6 +36,10 @@   , exactHalf   , exactThird   , blendPositive+  , unitMidpoint+  , unitBetween+  , unitClamp+  , unitIntervalRun   , divideByPositive   , ratioPositive   , multiplyPositive@@ -44,12 +48,14 @@  import Control.DeepSeq (NFData (..)) import Data.Bits ((.&.), shiftL, shiftR)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Ratio (Ratio, (%)) import qualified Data.Ratio as Ratio import GHC.Generics (Generic) import GHC.Exts (Int (I#)) import GHC.Integer.Logarithms (integerLog2#) import GHC.Real (Ratio ((:%)))+import Numeric.Natural (Natural)  -- | A checked wrapper around a reduced ratio with a strictly positive -- denominator. 'Ratio' owns normalization, including the unique zero@@ -245,6 +251,32 @@ blendPositive :: UnitInterval -> PositiveExact -> PositiveExact -> PositiveExact blendPositive (UnitInterval t) (PositiveExact a) (PositiveExact b) =   PositiveExact ((1 - t) * a + t * b)++-- | The exact midpoint of two unit parameters. A convex combination of two+-- admitted parameters stays in the closed unit interval without readmission.+unitMidpoint :: UnitInterval -> UnitInterval -> UnitInterval+unitMidpoint (UnitInterval a) (UnitInterval b) = UnitInterval ((a + b) * exactHalf)++-- | The parameter a unit fraction of the way from the first to the second, a+-- convex combination like 'unitMidpoint'.+unitBetween :: UnitInterval -> UnitInterval -> UnitInterval -> UnitInterval+unitBetween (UnitInterval a) (UnitInterval b) (UnitInterval t) = UnitInterval (a + (b - a) * t)++-- | The nearest point of the closed unit interval.+unitClamp :: ExactRational -> UnitInterval+unitClamp value = UnitInterval (max 0 (min 1 value))++-- | @intervals + 1@ evenly spaced points, both endpoints included: @first@,+-- then @first + k (final - first) / intervals@ for @k@ from one to+-- @intervals@. Zero intervals is @first@ alone, whose division is never+-- formed. Each point is a convex combination of the two, so none needs+-- readmission.+unitIntervalRun :: Natural -> UnitInterval -> UnitInterval -> NonEmpty UnitInterval+unitIntervalRun intervals (UnitInterval first) (UnitInterval final) =+  UnitInterval first :| fmap at [1 .. intervals]+ where+  at :: Natural -> UnitInterval+  at k = UnitInterval (first + (final - first) * ExactRational (toInteger k % toInteger intervals))  -- | The same Ratio division as 'exactDivide', with its nonzero precondition -- already discharged by the opaque positive divisor.

@@ -18,8 +18,19 @@   , curveStepEnd   , stepControlPoints   , evaluateStep-  , splitStepHalf+  , splitStep+  , ParameterSpan+  , ParameterSpanError (..)+  , parameterSpan+  , parameterSpanFrom+  , parameterSpanTo+  , restrictStep   , reverseStep+  , StepJet+  , stepJetValue+  , stepJetFirst+  , stepJetSecond+  , jetStep   , startJet   , endJet   , hermiteStep@@ -64,8 +75,8 @@ import Moonlight.Planar.Exact   ( ExactPoint, ExactRational, ExactVector (..), PositiveExact, UnitInterval   , addExactVectors, blendPositive, divideByPositive, exactCross-  , exactHalf, exactPoint, exactThird, positiveExactValue, positiveOne-  , positiveTwo, ratioPositive, translateExactPoint, unitHalf, unitIntervalValue+  , exactPoint, exactThird, positiveExactValue, positiveOne+  , positiveTwo, ratioPositive, translateExactPoint, unitIntervalValue   )  data CurveShape@@ -154,43 +165,48 @@  where   t = unitIntervalValue parameter --- | Exact half subdivision. The right child's controls are rebased at the--- shared split point; parameterization is inherited on each half interval.-splitStepHalf :: CurveStep -> (CurveStep, CurveStep)-splitStepHalf (CurveStep shape endpoint) = case shape of+-- | Exact de Casteljau subdivision at @t@. The left child is the source on+-- @[0,t]@ and the right child the source on @[t,1]@, each reparameterized+-- affinely over its own unit interval; the right child's controls are rebased+-- at the shared split point. A child at an endpoint parameter is stationary.+splitStep :: UnitInterval -> CurveStep -> (CurveStep, CurveStep)+splitStep parameter (CurveStep shape endpoint) = case shape of   Linear ->-    let midpoint = scaleVector exactHalf endpoint-     in (CurveStep Linear midpoint, CurveStep Linear midpoint)+    (CurveStep Linear (scaleVector t endpoint), CurveStep Linear (scaleVector (1 - t) endpoint))   Quadratic a ->-    let p = midpointVector zeroVector a-        q = midpointVector a endpoint-        m = midpointVector p q+    let p = scaleVector t a+        q = blend t a endpoint+        m = blend t p q      in (CurveStep (Quadratic p) m,          CurveStep (Quadratic (subtractVectors q m)) (subtractVectors endpoint m))   Cubic a b ->-    let p = midpointVector zeroVector a-        q = midpointVector a b-        r = midpointVector b endpoint-        u = midpointVector p q-        v = midpointVector q r-        m = midpointVector u v+    let p = scaleVector t a+        q = blend t a b+        r = blend t b endpoint+        u = blend t p q+        v = blend t q r+        m = blend t u v      in (CurveStep (Cubic p u) m,          CurveStep (Cubic (subtractVectors v m) (subtractVectors r m))            (subtractVectors endpoint m))+  -- Every level is demanded by both children, so each is bound strictly: a+  -- lazy level would be a thunk capturing the dynamic parameter.   RationalQuadratic a u v ->     let start = Homogeneous zeroVector positiveOne-        middle = weighted a u-        finish = weighted endpoint v-        p = blendHomogeneous unitHalf start middle-        q = blendHomogeneous unitHalf middle finish-        m = blendHomogeneous unitHalf p q-        midpoint = project m+        !middle = weighted a u+        !finish = weighted endpoint v+        !p = blendHomogeneous parameter start middle+        !q = blendHomogeneous parameter middle finish+        !m = blendHomogeneous parameter p q+        !point = project m         leftShape = rationalQuadratic (project p) (weight p) (weight m)-        rightShape = rationalQuadratic (subtractVectors (project q) midpoint)+        rightShape = rationalQuadratic (subtractVectors (project q) point)           (ratioPositive (weight q) (weight m))           (ratioPositive v (weight m))-     in (CurveStep leftShape midpoint,-         CurveStep rightShape (subtractVectors endpoint midpoint))+     in (CurveStep leftShape point,+         CurveStep rightShape (subtractVectors endpoint point))+ where+  t = unitIntervalValue parameter  reverseStep :: CurveStep -> CurveStep reverseStep (CurveStep shape endpoint) = CurveStep reversed (negateVector endpoint)@@ -202,8 +218,69 @@     RationalQuadratic a u v -> rationalQuadratic (subtractVectors a endpoint)       (ratioPositive u v) (ratioPositive positiveOne v) --- | Derivatives with respect to each segment's own unit parameter. Equality--- of these jets is C1 for equal-duration segment parameterizations, not arc length.+-- | Value, first and second derivative at one parameter, relative to the+-- step's start and with respect to its own unit parameter. The derivatives+-- are not unit speed; zero derivatives are lawful observations.+data StepJet = StepJet !ExactVector !ExactVector !ExactVector+  deriving stock (Eq, Ord, Show)++instance NFData StepJet where+  rnf (StepJet value first second) = rnf value `seq` rnf first `seq` rnf second++stepJetValue :: StepJet -> ExactVector+stepJetValue (StepJet value _ _) = value++stepJetFirst :: StepJet -> ExactVector+stepJetFirst (StepJet _ first _) = first++stepJetSecond :: StepJet -> ExactVector+stepJetSecond (StepJet _ _ second) = second++-- | Polynomial derivatives are Bernstein difference forms of the de Casteljau+-- levels. A rational quadratic is the quotient @C = N / W@ of its homogeneous+-- numerator by a positive weight; differentiating @N = W C@ gives+-- @C' = (N' - W'C) / W@ and @C'' = (N'' - W''C - 2W'C') / W@.+jetStep :: UnitInterval -> CurveStep -> StepJet+jetStep parameter (CurveStep shape endpoint) = case shape of+  Linear -> StepJet (scaleVector t endpoint) endpoint zeroVector+  Quadratic a ->+    let p = scaleVector t a+        q = blend t a endpoint+     in StepJet (blend t p q) (scaleVector 2 (subtractVectors q p))+          (scaleVector 2 (subtractVectors endpoint (scaleVector 2 a)))+  Cubic a b ->+    let p = scaleVector t a+        q = blend t a b+        r = blend t b endpoint+        u = blend t p q+        v = blend t q r+     in StepJet (blend t u v) (scaleVector 3 (subtractVectors v u))+          (scaleVector 6 (addExactVectors (subtractVectors r q) (subtractVectors p q)))+  RationalQuadratic a u v ->+    let start = Homogeneous zeroVector positiveOne+        middle = weighted a u+        finish = weighted endpoint v+        p = blendHomogeneous parameter start middle+        q = blendHomogeneous parameter middle finish+        m = blendHomogeneous parameter p q+        value = project m+        weightFirst = 2 * (positiveExactValue (weight q) - positiveExactValue (weight p))+        weightSecond = 2 * (1 - 2 * positiveExactValue u + positiveExactValue v)+        numeratorFirst = scaleVector 2 (subtractVectors (numerator q) (numerator p))+        numeratorSecond =+          scaleVector 2 (subtractVectors (numerator finish) (scaleVector 2 (numerator middle)))+        first = divideVector (subtractVectors numeratorFirst (scaleVector weightFirst value)) (weight m)+        second = divideVector+          (subtractVectors numeratorSecond+            (addExactVectors (scaleVector weightSecond value) (scaleVector (2 * weightFirst) first)))+          (weight m)+     in StepJet value first second+ where+  t = unitIntervalValue parameter++-- | Closed-form first derivatives of 'jetStep' at the endpoints, with respect+-- to each segment's own unit parameter. Equality of these jets is C1 for+-- equal-duration segment parameterizations, not arc length. startJet :: CurveStep -> ExactVector startJet (CurveStep shape endpoint) = case shape of   Linear -> endpoint@@ -329,6 +406,69 @@ locatedValue :: Located a -> a locatedValue (Located _ value) = value +-- | An ordered parameter interval of one step. Equal endpoints are admitted+-- and denote a single point, not an empty or reversed traversal.+data ParameterSpan = ParameterSpan !UnitInterval !UnitInterval+  deriving stock (Eq, Ord, Show)++instance NFData ParameterSpan where+  rnf (ParameterSpan from to) = rnf from `seq` rnf to++data ParameterSpanError = ReversedParameterSpan !UnitInterval !UnitInterval+  deriving stock (Eq, Ord, Show)++parameterSpan :: UnitInterval -> UnitInterval -> Either ParameterSpanError ParameterSpan+parameterSpan from to+  | from <= to = Right (ParameterSpan from to)+  | otherwise = Left (ReversedParameterSpan from to)++parameterSpanFrom :: ParameterSpan -> UnitInterval+parameterSpanFrom (ParameterSpan from _) = from++parameterSpanTo :: ParameterSpan -> UnitInterval+parameterSpanTo (ParameterSpan _ to) = to++-- | The step on @[a,b]@, reparameterized so that local @u@ is source+-- @a + (b - a) u@ and relocated to start at the source point at @a@. Its+-- controls are the polar forms of the source controls at @a@ and @b@, so no+-- parameter is divided and equal endpoints yield a stationary step.+restrictStep :: ParameterSpan -> Located CurveStep -> Located CurveStep+restrictStep (ParameterSpan from to) (Located anchor (CurveStep shape endpoint)) = case shape of+  Linear ->+    Located (place (scaleVector a endpoint)) (CurveStep Linear (scaleVector (b - a) endpoint))+  Quadratic c ->+    let polar s r = polarQuadratic mix s r zeroVector c endpoint+        start = polar from from+        relative = (`subtractVectors` start)+     in Located (place start)+          (CurveStep (Quadratic (relative (polar from to))) (relative (polar to to)))+  Cubic c d ->+    let polar s r q = polarCubic mix s r q zeroVector c d endpoint+        start = polar from from from+        relative = (`subtractVectors` start)+     in Located (place start)+          (CurveStep (Cubic (relative (polar from from to)) (relative (polar from to to)))+            (relative (polar to to to)))+  RationalQuadratic c u v ->+    let polar s r = polarQuadratic blendHomogeneous s r+          (Homogeneous zeroVector positiveOne) (weighted c u) (weighted endpoint v)+        initial = polar from from+        middle = polar from to+        final = polar to to+        start = project initial+        relative = (`subtractVectors` start)+     in Located (place start)+          (CurveStep+            (rationalQuadratic (relative (project middle))+              (ratioPositive (weight middle) (weight initial))+              (ratioPositive (weight final) (weight initial)))+            (relative (project final)))+ where+  a = unitIntervalValue from+  b = unitIntervalValue to+  mix = blend . unitIntervalValue+  place = translateExactPoint anchor+ -- | One affine value owns both the point action and the relative vector action. transformLocatedTrail :: Affine2 -> Located OpenTrail -> Located OpenTrail transformLocatedTrail placement (Located anchor trail) =@@ -404,14 +544,30 @@ weight :: Homogeneous -> PositiveExact weight (Homogeneous _ w) = w +numerator :: Homogeneous -> ExactVector+numerator (Homogeneous value _) = value+ project :: Homogeneous -> ExactVector-project (Homogeneous (ExactVector x y) w) =-  ExactVector (divideByPositive x w) (divideByPositive y w)+project (Homogeneous value w) = divideVector value w +divideVector :: ExactVector -> PositiveExact -> ExactVector+divideVector (ExactVector x y) w = ExactVector (divideByPositive x w) (divideByPositive y w)+ blendHomogeneous :: UnitInterval -> Homogeneous -> Homogeneous -> Homogeneous blendHomogeneous t (Homogeneous a u) (Homogeneous b v) =   Homogeneous (blend (unitIntervalValue t) a b) (blendPositive t u v) +-- | Polar forms (blossoms) of Bernstein controls: symmetric and affine in each+-- parameter, with the curve itself on the diagonal. Each parameter selects+-- one de Casteljau level, so parameters in the unit interval keep homogeneous+-- weights positive.+polarQuadratic :: (s -> v -> v -> v) -> s -> s -> v -> v -> v -> v+polarQuadratic mix s r p0 p1 p2 = mix r (mix s p0 p1) (mix s p1 p2)++polarCubic :: (s -> v -> v -> v) -> s -> s -> s -> v -> v -> v -> v -> v+polarCubic mix s r q p0 p1 p2 p3 =+  mix q (polarQuadratic mix s r p0 p1 p2) (polarQuadratic mix s r p1 p2 p3)+ zeroVector :: ExactVector zeroVector = ExactVector 0 0 @@ -426,9 +582,6 @@  blend :: ExactRational -> ExactVector -> ExactVector -> ExactVector blend t a b = addExactVectors (scaleVector (1 - t) a) (scaleVector t b)--midpointVector :: ExactVector -> ExactVector -> ExactVector-midpointVector = blend exactHalf  dotVector :: ExactVector -> ExactVector -> ExactRational dotVector (ExactVector ax ay) (ExactVector bx by) = ax * bx + ay * by

@@ -0,0 +1,180 @@+-- | Approximately unit tangent frames on canonical curves, and finite runs of+-- stations placed by arc fraction.+--+-- A nonzero rational tangent @t@ has an exact direction and perpendicular,+-- but its unit normalization is generally irrational. A frame therefore+-- scales @t@ and its perpendicular by one positive rational @r@, a lower+-- bound of @1 / |t|@ taken from the radical-length owner. The frame's columns+-- are @r t@ and @(-r t_y, r t_x)@: exactly orthogonal, of equal length and+-- nonsingular. Their squared length @r^2 |t|^2@ is an exact rational in+-- @[1 - tolerance, 1]@, so the length itself lies in the same interval. The+-- second column is the mathematical left normal; in y-down drawing space it+-- appears on the viewer's right of the direction of travel.+--+-- A frame is read at one of two sites. A sampled site answers an arc-length+-- request and keeps that request's distance residual. An exact site is a+-- step and parameter of the source itself: it carries no residual, since no+-- distance was requested. Either may lie on a join between steps. A join is+-- regular only where both steps' tangents point the same way; a corner has+-- no unique tangent and refuses, as does a stationary tangent.+module Moonlight.Planar.Curve.Frame+  ( FramePolicy+  , framePolicy+  , exactTrailSite+  , FrameSite (..)+  , FrameError (..)+  , MeasuredFrame+  , regularFrame+  , measuredFrameIso+  , measuredFrameSite+  , measuredFrameTangent+  , measuredFrameScaleSquared+  , FractionRun+  , RunError (..)+  , fractionRun+  , runFractions+  , sampleRun+  ) where++import Data.Bifunctor (first)+import Data.Bits (toIntegralSized)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Numeric.Natural (Natural)+import Moonlight.Planar.Affine (AffineIso2, affine2, affineIso2)+import Moonlight.Planar.Curve (Subpath (..), stepJetFirst)+import Moonlight.Planar.Curve.Measure+  ( ArcSample, MeasureError, MeasuredTrail, measuredSource, pointAtFraction, sampleSite )+import Moonlight.Planar.Exact+  ( ExactRational, ExactVector (..), PositiveExact, UnitInterval, divideByPositive+  , exactCross, exactPointCoordinates, positiveExact, positiveExactValue, unitIntervalValue )+import Moonlight.Planar.Internal.CurveSource+  ( TrailSite, joinNeighbourJet, selectSite, siteJet, siteParameter, sitePoint, siteStepIndex )+import Moonlight.Planar.Internal.ExactRational (unitIntervalRun)+import Moonlight.Planar.Internal.Length+  ( RadicalPrecision, euclideanLengthEnclosure, lengthEnclosureLower )++-- | The precision of the inverse-speed enclosure and the largest admitted+-- deficit of a frame's squared scale below one.+data FramePolicy = FramePolicy !RadicalPrecision !PositiveExact+  deriving stock (Eq, Show)++framePolicy :: RadicalPrecision -> PositiveExact -> FramePolicy+framePolicy = FramePolicy++-- | The site at an exact parameter of a source's step, selected by its index+-- among the source's actual steps. At a join the selection is the side: the+-- earlier step at parameter one or the later step at parameter zero.+exactTrailSite :: Subpath -> Int -> UnitInterval -> Either FrameError TrailSite+exactTrailSite source index parameter =+  maybe (Left (SiteStepOutOfRange index)) Right (selectSite source index parameter)++data FrameSite+  = SampledSite !ArcSample+  | ExactSite !TrailSite+  deriving stock (Eq, Show)++-- | Refusals name the site's step and parameter. A normalization refusal+-- carries the squared scale reached and the policy's deficit.+data FrameError+  = SiteStepOutOfRange !Int+  | StationaryFrame !Int !UnitInterval+  | CornerFrame !Int !UnitInterval+  | NormalizationUnresolved !Int !UnitInterval !ExactRational !ExactRational+  deriving stock (Eq, Show)++-- | The site, the frame, the exact tangent it normalizes, and the exact+-- squared length of either column.+data MeasuredFrame = MeasuredFrame !FrameSite !AffineIso2 !ExactVector !ExactRational+  deriving stock (Eq, Show)++measuredFrameSite :: MeasuredFrame -> FrameSite+measuredFrameSite (MeasuredFrame site _ _ _) = site++-- | Maps local @+x@ to the scaled tangent and local @+y@ to the scaled left+-- normal, with the origin at the site's point. It is fed to attachment as it+-- is; nothing downstream renormalizes it.+measuredFrameIso :: MeasuredFrame -> AffineIso2+measuredFrameIso (MeasuredFrame _ frame _ _) = frame++-- | The first derivative of the site's step at the site's parameter.+measuredFrameTangent :: MeasuredFrame -> ExactVector+measuredFrameTangent (MeasuredFrame _ _ tangent _) = tangent++-- | The squared length of each column, in @[1 - tolerance, 1]@.+measuredFrameScaleSquared :: MeasuredFrame -> ExactRational+measuredFrameScaleSquared (MeasuredFrame _ _ _ scale) = scale++regularFrame :: FramePolicy -> FrameSite -> Either FrameError MeasuredFrame+regularFrame (FramePolicy precision tolerance) frameSite = do+  speedSquared <- first (const (StationaryFrame index parameter)) (positiveExact (dot tangent tangent))+  case joinNeighbourJet site of+    Just neighbour+      | let other = stepJetFirst neighbour+      , exactCross other tangent /= 0 || dot other tangent <= 0 ->+          Left (CornerFrame index parameter)+    _ -> Right ()+  -- |t / |t|^2| = 1 / |t|, enclosed from below by a rational r.+  let ExactVector x y = tangent+      scale = lengthEnclosureLower (euclideanLengthEnclosure precision+        [(divideByPositive x speedSquared, divideByPositive y speedSquared)])+      column = ExactVector (scale * x) (scale * y)+      ExactVector u v = column+      scaleSquared = scale * scale * positiveExactValue speedSquared+      deficit = positiveExactValue tolerance+      refused = NormalizationUnresolved index parameter scaleSquared deficit+      (px, py) = exactPointCoordinates (sitePoint site)+  if scaleSquared < 1 - deficit+    then Left refused+    else maybe (Left refused) (\frame -> Right (MeasuredFrame frameSite frame tangent scaleSquared))+      (affineIso2 (affine2 column (ExactVector (negate v) u) (ExactVector px py)))+ where+  site = case frameSite of+    SampledSite sample -> sampleSite sample+    ExactSite exact -> exact+  tangent = stepJetFirst (siteJet site)+  index = siteStepIndex site+  parameter = siteParameter site++dot :: ExactVector -> ExactVector -> ExactRational+dot (ExactVector a b) (ExactVector c d) = a * c + b * d++-- | Evenly spaced arc fractions, both ends included, in order. The count is+-- the placement budget; more than one station needs positive spacing.+newtype FractionRun = FractionRun (NonEmpty UnitInterval)+  deriving stock (Eq, Show)++-- | An empty run, a run whose spacing is not positive, a closed source asked+-- to place a station at both ends of its seam, or a refused station.+data RunError+  = EmptyRun !Int+  | NonPositiveSpacing !UnitInterval !UnitInterval+  | RunRepeatsSeam+  | RunStationRefused !MeasureError+  deriving stock (Eq, Show)++-- The interval count is admitted as a 'Natural' in one total step, on+-- 'Integer' so that no 'Int' subtraction can wrap.+fractionRun :: Int -> UnitInterval -> UnitInterval -> Either RunError FractionRun+fractionRun count start end = case toIntegralSized (toInteger count - 1) of+  Nothing -> Left (EmptyRun count)+  Just intervals+    | intervals > (0 :: Natural) && unitIntervalValue end <= unitIntervalValue start ->+        Left (NonPositiveSpacing start end)+    | otherwise -> Right (FractionRun (unitIntervalRun intervals start end))++runFractions :: FractionRun -> NonEmpty UnitInterval+runFractions (FractionRun fractions) = fractions++-- | One sample per station, in the run's order. On a closed source fraction+-- zero and fraction one are the same seam point, so a run holding both would+-- place two stations there; it is refused rather than silently merged.+sampleRun :: FractionRun -> MeasuredTrail -> Either RunError (NonEmpty ArcSample)+sampleRun (FractionRun fractions) trail+  | closed && unitIntervalValue (NonEmpty.head fractions) == 0+      && unitIntervalValue (NonEmpty.last fractions) == 1 = Left RunRepeatsSeam+  | otherwise = first RunStationRefused (traverse (`pointAtFraction` trail) fractions)+ where+  closed = case measuredSource trail of+    ClosedSubpath _ -> True+    OpenSubpath _ -> False

@@ -32,11 +32,11 @@ import Moonlight.Planar.Affine (Affine2, transformPoint) import Moonlight.Planar.Curve   ( CurveStep, OpenTrail, ClosedTrail, Located, location, locatedValue-  , trailSteps, closedTrailSteps, curveStepEnd, stepControlPoints, splitStepHalf )+  , trailSteps, closedTrailSteps, curveStepEnd, stepControlPoints, splitStep ) import Moonlight.Planar.Exact   ( ExactPoint, ExactVector (..), ExactRational   , PositiveExact, positiveExactValue, exactHalf, divideByPositive, positiveSumSquares-  , exactVectorFromPoints, translateExactPoint )+  , exactVectorFromPoints, translateExactPoint, unitHalf )  data LoweringPolicy = LoweringPolicy !PositiveExact !Affine2 !Int !Int @@ -145,7 +145,7 @@         else if depth == 0           then Left (SubdivisionDepthExhausted index t0 t1 bound)           else do-            let (left, right) = splitStepHalf step+            let (left, right) = splitStep unitHalf step                 middle = (t0 + t1) * exactHalf                 splitPoint = translateExactPoint from (curveStepEnd left)             (afterLeft, leftSpans) <- descend policy index (depth - 1) remaining from t0 middle left

@@ -0,0 +1,522 @@+-- | Certified Euclidean arc length of canonical curves, in the coordinates of+-- the submitted curve. A measured trail is an immutable observation of its+-- source, never an editable shadow curve: it retains the source subpath, its+-- accepted spans, and their cumulative rational length enclosures. The curve's+-- arc length is enclosed, not represented; no radical expression of the arc+-- itself is fabricated.+--+-- Enclosure kernel, one for all four shapes. For a span with Euclidean control+-- polygon @P0..Pn@, the chord @|Pn - P0|@ is a lower bound and the polygon+-- length an upper bound of its arc length. For polynomial shapes this is the+-- classical Bernstein argument. For a positive-weight rational quadratic with+-- controls @P0,P1,P2@ and weights @(1,a,b)@, one homogeneous de Casteljau step+-- at any @t@ in @[0,1]@ yields @p@ on segment @P0P1@, @q@ on @P1P2@ and @m@ on+-- @pq@: each is a convex combination with positive homogeneous weights, so its+-- projection lies on the segment between the projected endpoints. By the+-- triangle inequality the refined chain @P0,p,m,q,P2@ is no longer than+-- @P0,P1,P2@, and its chords are no shorter than @P0P2@. The children, after+-- division by a common positive weight, are again positive-weight rational+-- quadratics, so the argument repeats without any square root. Under repeated+-- subdivision the inscribed chord polygons converge to the arc, which bounds+-- it from below, and the control polygons converge from above; lower+-- semicontinuity of length makes the limit of the nonincreasing polygon+-- lengths an upper bound, and endpoint distance is the lower bound at every+-- stage. Validity is independent of convergence rate: acceptance is decided by+-- the actual outward gap, and exhaustion refuses.+--+-- Error allocation is global and split in two halves. Let @U0@ be the outward+-- upper bound of the whole source's control-polygon length and @N@ the number+-- of source steps. A span @[a,b]@ of any step is accepted when its outward gap+-- @upper - lower@ is at most+-- @(tolerance / 2) * (lower / U0 + (b - a) / N)@. Summed over the accepted+-- spans, the relative half is at most @(tolerance / 2) * L / U0 <=+-- tolerance / 2@, where @L <= U0@ is the arc length, since the chords' lower+-- bounds sum to at most @L@; the parameter half is exactly+-- @(tolerance / 2) * N / N = tolerance / 2@, since the accepted spans of each+-- step partition its parameter interval. The whole gap is therefore at most+-- the tolerance. The outward dyadic rounding of every enclosure lies inside+-- the compared gap, so it is charged to the same allowance. The relative half+-- alone never accepts a span straddling a turning point, whose chord stays a+-- fixed fraction of its polygon however small it becomes; the parameter half+-- shrinks only linearly with the span while such a gap shrinks faster. If+-- @U0@ is zero the relative half is zero and every span is stationary with+-- zero gap; a source with no steps has no spans and never divides by @N@.+-- The partition, and so the cost in spans, depends on the parameterization;+-- the Euclidean length enclosure and its global tolerance do not.+--+-- Arithmetic is budgeted before it is spent. Every source step is admitted+-- against the bit budget, with its located start, controls and rational+-- weights, before any length is observed; every generated child is admitted+-- with its parameters, and every observed enclosure endpoint, prefix and+-- total included, is admitted before it is compared. A query's request, and+-- the residual and bracket it returns, are admitted the same way. The two+-- budgets bound different things: the radical precision bounds scratch work+-- inside one root, while the bit budget bounds the source and every retained+-- exact value. A high precision is never refused for its value; an+-- irrational length at high precision is refused because its retained+-- enclosure endpoints exceed the budget, while an exact root stays small at+-- any precision.+module Moonlight.Planar.Curve.Measure+  ( Distance+  , DistanceError (..)+  , distance+  , distanceValue+  , MeasurePolicy+  , measurePolicy+  , measureTolerance+  , measurePrecision+  , measureBudget+  , SubdivisionBudget+  , SubdivisionBudgetError (..)+  , subdivisionBudget+  , budgetDepth+  , budgetLeaves+  , budgetBits+  , BudgetObligation (..)+  , RadicalPrecision+  , RadicalPrecisionError (..)+  , radicalPrecision+  , radicalPrecisionBits+  , LengthEnclosure+  , lengthEnclosureLower+  , lengthEnclosureUpper+  , lengthEnclosureWidth+  , MeasureObligation (..)+  , MeasureError (..)+  , MeasuredTrail+  , measureSubpath+  , measuredSource+  , measuredSpans+  , lengthBounds+  , MeasuredSpan+  , measuredSpanStep+  , measuredSpanFrom+  , measuredSpanTo+  , measuredSpanStart+  , measuredSpanPiece+  , measuredSpanLength+  , measuredSpanPrefix+  , JoinSide (..)+  , TrailSite+  , siteSource+  , siteStepIndex+  , siteParameter+  , sitePoint+  , siteJoinSide+  , siteJet+  , ArcSample+  , sampleSite+  , sampleParameterFrom+  , sampleParameterTo+  , sampleResidual+  , pointAtLength+  , pointAtFraction+  ) where++import Control.Applicative ((<|>))+import Control.DeepSeq (NFData (..))+import Control.Monad (foldM, when)+import Data.Foldable (fold, toList, traverse_)+import Data.Sequence (Seq, ViewL (..), ViewR (..))+import qualified Data.Sequence as Seq+import Moonlight.Planar.Curve (CurveStep, Subpath, curveStepEnd, splitStep, stepControlPoints)+import Moonlight.Planar.Exact+  ( ExactPoint, ExactRational, ExactVector (..), PositiveExact, UnitInterval+  , divideByPositive, exactHalf, exactPointBitWidth, exactRationalBitWidth, positiveExact+  , positiveExactValue, translateExactPoint, unitHalf, unitIntervalValue, unitOne, unitZero )+import Moonlight.Planar.Internal.CurveBudget+  ( BudgetObligation (..), SubdivisionBudget, SubdivisionBudgetError (..), budgetBits, budgetDepth+  , budgetLeaves, subdivisionBudget )+import Moonlight.Planar.Internal.CurveSource+  ( JoinSide (..), SourceStep, TrailSite, siteJet, siteJoinSide, siteParameter, sitePoint+  , siteSource, siteStepIndex, sourceStepCurve, sourceStepIndex, sourceStepStart+  , sourceSteps, spanBits, trailSite )+import Moonlight.Planar.Internal.ExactRational (unitMidpoint)+import Moonlight.Planar.Internal.Length+  ( LengthEnclosure, RadicalPrecision, RadicalPrecisionError (..), enclosureBetween+  , euclideanLengthEnclosure, lengthEnclosureLower, lengthEnclosureUpper+  , lengthEnclosureWidth, radicalPrecision, radicalPrecisionBits )++-- | A nonnegative distance, zero included: along a trail, or between curves.+newtype Distance = Distance ExactRational+  deriving stock (Eq, Ord, Show)++instance NFData Distance where+  rnf (Distance value) = rnf value++newtype DistanceError = NegativeDistance ExactRational+  deriving stock (Eq, Show)++distance :: ExactRational -> Either DistanceError Distance+distance value+  | value >= 0 = Right (Distance value)+  | otherwise = Left (NegativeDistance value)++distanceValue :: Distance -> ExactRational+distanceValue (Distance value) = value++-- | Tolerance, radical precision, and the subdivision budget: depth, leaves,+-- and the largest admitted bit width of any span coordinate, weight,+-- parameter or observed enclosure endpoint. Each part arrives admitted.+data MeasurePolicy = MeasurePolicy !PositiveExact !RadicalPrecision !SubdivisionBudget+  deriving stock (Eq, Show)++instance NFData MeasurePolicy where+  rnf (MeasurePolicy tolerance precision budget) =+    rnf tolerance `seq` rnf precision `seq` rnf budget++measurePolicy :: PositiveExact -> RadicalPrecision -> SubdivisionBudget -> MeasurePolicy+measurePolicy = MeasurePolicy++measureTolerance :: MeasurePolicy -> PositiveExact+measureTolerance (MeasurePolicy tolerance _ _) = tolerance++measurePrecision :: MeasurePolicy -> RadicalPrecision+measurePrecision (MeasurePolicy _ precision _) = precision++measureBudget :: MeasurePolicy -> SubdivisionBudget+measureBudget (MeasurePolicy _ _ budget) = budget++-- | The obligation a span could not discharge: the subdivision budget, or one+-- of measurement's own. A precision refusal carries the+-- span's rounding width and its share of the global allowance; subdividing+-- cannot help once rounding alone exceeds that share. An ambiguous distance+-- carries the best residual the enclosures certify, which exceeds the+-- inverse's allowance.+data MeasureObligation+  = MeasureBudgetExhausted !BudgetObligation+  | PrecisionExhausted !ExactRational !ExactRational+  | AmbiguousDistance !ExactRational+  deriving stock (Eq, Show)++-- | A refused span names its source step index (in 'closedTrailSteps' order for+-- a closed trail) and parameter bracket within that step. A distance above+-- the certified upper length is beyond the trail; one above the lower length+-- but not the upper is undecided at this enclosure. Neither is clamped. A+-- fraction whose share of the length uncertainty consumes the tolerance+-- carries that share and the tolerance. A query request refused before any+-- span is consulted carries its obligation alone. A trail with no steps has no+-- source span to sample.+data MeasureError+  = SpanRefused !Int !UnitInterval !UnitInterval !MeasureObligation+  | RequestRefused !MeasureObligation+  | DistanceBeyondTrail !ExactRational !LengthEnclosure+  | DistanceUnresolved !ExactRational !LengthEnclosure+  | FractionBudgetExhausted !ExactRational !ExactRational+  | EmptyTrailSample+  deriving stock (Eq, Show)++-- | One accepted span: the source step it refines, its parameter bracket, its+-- located start, the child step obtained by subdivision, its enclosure, and+-- the cumulative enclosure of every span before it.+data MeasuredSpan = MeasuredSpan !Leaf !LengthEnclosure+  deriving stock (Eq, Show)++data Leaf = Leaf !SourceStep !UnitInterval !UnitInterval !ExactPoint !CurveStep !LengthEnclosure+  deriving stock (Eq, Show)++instance NFData MeasuredSpan where+  rnf (MeasuredSpan (Leaf step from to start piece enclosure) prefix) =+    rnf step `seq` rnf from `seq` rnf to `seq` rnf start `seq` rnf piece+      `seq` rnf enclosure `seq` rnf prefix++measuredSpanStep :: MeasuredSpan -> Int+measuredSpanStep (MeasuredSpan (Leaf step _ _ _ _ _) _) = sourceStepIndex step++measuredSpanFrom :: MeasuredSpan -> UnitInterval+measuredSpanFrom (MeasuredSpan (Leaf _ from _ _ _ _) _) = from++measuredSpanTo :: MeasuredSpan -> UnitInterval+measuredSpanTo (MeasuredSpan (Leaf _ _ to _ _ _) _) = to++measuredSpanStart :: MeasuredSpan -> ExactPoint+measuredSpanStart (MeasuredSpan (Leaf _ _ _ start _ _) _) = start++measuredSpanPiece :: MeasuredSpan -> CurveStep+measuredSpanPiece (MeasuredSpan (Leaf _ _ _ _ piece _) _) = piece++measuredSpanLength :: MeasuredSpan -> LengthEnclosure+measuredSpanLength (MeasuredSpan (Leaf _ _ _ _ _ enclosure) _) = enclosure++measuredSpanPrefix :: MeasuredSpan -> LengthEnclosure+measuredSpanPrefix (MeasuredSpan _ prefix) = prefix++-- | An open trail is measured from its anchor. A closed trail is measured as+-- exactly one lap, with its seam at the anchor: its steps are+-- 'closedTrailSteps', the explicit closing step last.+data MeasuredTrail = MeasuredTrail !Subpath !MeasurePolicy !(Seq MeasuredSpan) !LengthEnclosure+  deriving stock (Eq, Show)++instance NFData MeasuredTrail where+  rnf (MeasuredTrail source policy spans total) =+    rnf source `seq` rnf policy `seq` rnf spans `seq` rnf total++measuredSource :: MeasuredTrail -> Subpath+measuredSource (MeasuredTrail source _ _ _) = source++measuredSpans :: MeasuredTrail -> Seq MeasuredSpan+measuredSpans (MeasuredTrail _ _ spans _) = spans++-- | The trail's length lies in this enclosure, whose width is at most the+-- policy tolerance.+lengthBounds :: MeasuredTrail -> LengthEnclosure+lengthBounds (MeasuredTrail _ _ _ total) = total++-- | An answer to an inverse-length query: a site on its source, and a bracket+-- of that step's parameters containing the site's. Every parameter in the+-- bracket has arc distance within the residual of the request. The bracket is+-- certified, not maximal; it does not claim a unique inverse, which a+-- stationary span does not have.+data ArcSample = ArcSample !TrailSite !UnitInterval !UnitInterval !ExactRational+  deriving stock (Eq, Show)++instance NFData ArcSample where+  rnf (ArcSample site from to residual) =+    rnf site `seq` rnf from `seq` rnf to `seq` rnf residual++sampleSite :: ArcSample -> TrailSite+sampleSite (ArcSample site _ _ _) = site++sampleParameterFrom :: ArcSample -> UnitInterval+sampleParameterFrom (ArcSample _ from _ _) = from++sampleParameterTo :: ArcSample -> UnitInterval+sampleParameterTo (ArcSample _ _ to _) = to++sampleResidual :: ArcSample -> ExactRational+sampleResidual (ArcSample _ _ _ residual) = residual++-- | Precision, the tolerance shares per unit of chord and per unit of one+-- step's parameter, and the bit budget.+data Measuring = Measuring !RadicalPrecision !ExactRational !ExactRational !Int++measureSubpath :: MeasurePolicy -> Subpath -> Either MeasureError MeasuredTrail+measureSubpath policy@(MeasurePolicy tolerance precision budget) source = do+  -- Coordinates, weights and parameters first; no length is observed from a+  -- step the budget has not admitted. Then each source polygon and their sums.+  traverse_ (\step -> admitBits bits (whole step) (stepBits step)) selected+  traverse_ (\(step, polygon, prefix) -> admitEnclosure bits (whole step) polygon *> admitEnclosure bits (whole step) prefix)+    (Seq.zip3 selected polygons (Seq.drop 1 (Seq.scanl (<>) mempty polygons)))+  (_, measured) <- foldM appendStep (leaves, Seq.empty) selected+  let prefixes = Seq.scanl (<>) mempty (fmap leafLength measured)+  traverse_ (\(Leaf step t0 t1 _ _ _, after) -> admitEnclosure bits (SpanRefused (sourceStepIndex step) t0 t1) after)+    (Seq.zip measured (Seq.drop 1 prefixes))+  pure (MeasuredTrail source policy+    (Seq.zipWith (flip MeasuredSpan) prefixes measured) (fold (fmap leafLength measured)))+ where+  depth = budgetDepth budget+  leaves = budgetLeaves budget+  bits = budgetBits budget+  selected = sourceSteps source+  whole step = SpanRefused (sourceStepIndex step) unitZero unitOne+  stepBits step = spanBits (sourceStepStart step) unitZero unitOne (sourceStepCurve step)+  polygons = fmap (controlPolygon precision . sourceStepCurve) selected+  polygonUpper = lengthEnclosureUpper (fold polygons)+  -- A source whose control polygon has zero length is stationary; its every+  -- span then has zero gap. A source with no steps has no spans, so its+  -- parameter share is never read.+  halfTolerance = positiveExactValue tolerance * exactHalf+  lengthShare = either (const 0) (divideByPositive halfTolerance) (positiveExact polygonUpper)+  parameterShare = either (const 0) (divideByPositive halfTolerance)+    (positiveExact (fromIntegral (Seq.length selected)))+  measuring = Measuring precision lengthShare parameterShare bits+  appendStep (remaining, prefix) step = do+    (remainingAfter, spans) <-+      descend measuring step depth remaining (sourceStepStart step) unitZero unitOne (sourceStepCurve step)+    pure (remainingAfter, prefix <> spans)++-- The binary subdivision tree is consumed directly, as in lowering; the depth+-- and leaf budgets bound traversal before any exponential tree exists.+descend+  :: Measuring -> SourceStep -> Int -> Int -> ExactPoint -> UnitInterval -> UnitInterval -> CurveStep+  -> Either MeasureError (Int, Seq Leaf)+descend measuring@(Measuring precision lengthShare parameterShare budget) source depth remaining from t0 t1 step+  | remaining <= 0 = refuse (MeasureBudgetExhausted LeavesExhausted)+  | width > budget = refuse (MeasureBudgetExhausted (BitsExhausted width))+  | observed > budget = refuse (MeasureBudgetExhausted (BitsExhausted observed))+  | lengthEnclosureWidth enclosure <= allowance =+      Right (remaining - 1, Seq.singleton (Leaf source t0 t1 from step enclosure))+  | optimisticGap <= optimisticAllowance && rounding > allowance =+      refuse (PrecisionExhausted rounding allowance)+  | depth == 0 = refuse (MeasureBudgetExhausted DepthExhausted)+  | otherwise = do+      let (left, right) = splitStep unitHalf step+          middle = unitMidpoint t0 t1+          splitPoint = translateExactPoint from (curveStepEnd left)+      (afterLeft, leftLeaves) <- descend measuring source (depth - 1) remaining from t0 middle left+      (afterRight, rightLeaves) <- descend measuring source (depth - 1) afterLeft splitPoint middle t1 right+      pure (afterRight, leftLeaves <> rightLeaves)+ where+  refuse :: MeasureObligation -> Either MeasureError (Int, Seq Leaf)+  refuse = Left . SpanRefused (sourceStepIndex source) t0 t1+  width = spanBits from t0 t1 step+  chord = chordLength precision step+  polygon = controlPolygon precision step+  observed = max (enclosureBits chord) (enclosureBits polygon)+  enclosure = enclosureBetween chord polygon+  spanShare = parameterShare * (unitIntervalValue t1 - unitIntervalValue t0)+  allowance = lengthShare * lengthEnclosureLower chord + spanShare+  -- The same comparison with rounding in the span's favour: if even that+  -- fails, the gap is geometric and subdivision reduces it. If it passes but+  -- rounding alone exceeds the allowance, subdivision cannot help: it halves+  -- the parameter term while each child's rounding stays near @2^-precision@+  -- per radical term.+  optimisticGap = lengthEnclosureLower polygon - lengthEnclosureUpper chord+  optimisticAllowance = lengthShare * lengthEnclosureUpper chord + spanShare+  rounding = lengthEnclosureWidth chord + lengthEnclosureWidth polygon++-- | A point whose arc distance from the start is within the residual, at most+-- the policy tolerance, of the request. Only a request at most the certified+-- lower length is answered. The accepted span whose cumulative enclosures+-- bracket the request is bisected with the same kernel; a side is taken only+-- when enclosures separate from the request.+pointAtLength :: Distance -> MeasuredTrail -> Either MeasureError ArcSample+pointAtLength (Distance target) trail@(MeasuredTrail _ (MeasurePolicy tolerance _ budget) _ total)+  | targetBits > bits = Left (RequestRefused (MeasureBudgetExhausted (BitsExhausted targetBits)))+  | target > lengthEnclosureUpper total = Left (DistanceBeyondTrail target total)+  | target > lengthEnclosureLower total = Left (DistanceUnresolved target total)+  | otherwise = inverseLength (positiveExactValue tolerance) target trail >>= admitSample bits+ where+  targetBits = exactRationalBitWidth target+  bits = budgetBits budget++-- | The request's fraction of the lower length bound, which differs from the+-- same fraction of the true length by at most the fraction of the total+-- width. That share is reserved from the tolerance before the inverse is+-- refined, so the widened residual stays within tolerance.+pointAtFraction :: UnitInterval -> MeasuredTrail -> Either MeasureError ArcSample+pointAtFraction fraction trail@(MeasuredTrail _ (MeasurePolicy tolerance _ budget) _ total)+  | shareBits > bits = Left (RequestRefused (MeasureBudgetExhausted (BitsExhausted shareBits)))+  | derivedBits > bits = Left (RequestRefused (MeasureBudgetExhausted (BitsExhausted derivedBits)))+  | reserved >= limit = Left (FractionBudgetExhausted reserved limit)+  | otherwise = inverseLength (limit - reserved) target trail >>= admitSample bits . widen+ where+  bits = budgetBits budget+  share = unitIntervalValue fraction+  target = share * lengthEnclosureLower total+  -- The fraction first; the derived target and reserve only once it is admitted.+  shareBits = exactRationalBitWidth share+  derivedBits = max (exactRationalBitWidth target) (exactRationalBitWidth reserved)+  limit = positiveExactValue tolerance+  reserved = share * lengthEnclosureWidth total+  widen (ArcSample site from to residual) = ArcSample site from to (residual + reserved)++-- | A returned sample's residual, bracket and point are retained exact values,+-- admitted like any other before the sample is returned.+admitSample :: Int -> ArcSample -> Either MeasureError ArcSample+admitSample budget sample@(ArcSample site from to residual)+  | width > budget = Left (SpanRefused (siteStepIndex site) from to (MeasureBudgetExhausted (BitsExhausted width)))+  | otherwise = Right sample+ where+  width = foldr (max . exactRationalBitWidth) (exactPointBitWidth (sitePoint site))+    [residual, unitIntervalValue from, unitIntervalValue to]++-- | The query context shared by one inverse: the source, precision, bit+-- budget, residual allowance and target.+data Inverse = Inverse !Subpath !RadicalPrecision !Int !ExactRational !ExactRational++-- | Invariant: the target is at most the trail's certified lower length.+inverseLength :: ExactRational -> ExactRational -> MeasuredTrail -> Either MeasureError ArcSample+inverseLength limit target (MeasuredTrail source (MeasurePolicy _ precision budget) spans _) =+  case firstMonotone (\span' -> lengthEnclosureUpper (spanAfter span') > target) spans of+    -- No span ends certainly beyond the request, so it equals the trail's+    -- exact length and the trail's end answers it.+    Nothing -> case Seq.viewr spans of+      EmptyR -> Left EmptyTrailSample+      _ :> final -> boundary final+    Just span'@(MeasuredSpan (Leaf step t0 t1 start piece _) before)+      | lengthEnclosureLower (spanAfter span') >= target ->+          bisect inverse step depth start t0 t1 piece before (spanAfter span')+      -- The span's end is neither certainly before nor after the request.+      | otherwise -> boundary span'+ where+  inverse = Inverse source precision (budgetBits budget) limit target+  depth = budgetDepth budget+  boundary span'@(MeasuredSpan (Leaf step _ t1 start piece _) _) =+    let after = spanAfter span'+        residual = max (target - lengthEnclosureLower after) (lengthEnclosureUpper after - target)+     in if residual <= limit+          then Right (ArcSample (trailSite source step t1 (translateExactPoint start (curveStepEnd piece))) t1 t1 residual)+          else Left (SpanRefused (sourceStepIndex step) t1 t1 (AmbiguousDistance residual))++-- | Invariant: the arc distance at @tLo@ is at most the target and at @tHi@+-- at least it, witnessed by the separated enclosures @before@ and @after@.+-- As in 'descend', a piece is admitted before any enclosure is taken from it,+-- and the left child before its chord and polygon are observed.+bisect+  :: Inverse -> SourceStep -> Int -> ExactPoint -> UnitInterval -> UnitInterval -> CurveStep+  -> LengthEnclosure -> LengthEnclosure -> Either MeasureError ArcSample+bisect inverse@(Inverse source precision budget limit target) step depth from tLo tHi piece before after+  | width > budget = refuse (MeasureBudgetExhausted (BitsExhausted width))+  | pieceBits > budget = refuse (MeasureBudgetExhausted (BitsExhausted pieceBits))+  | residual <= limit = Right (ArcSample (trailSite source step tLo from) tLo tHi residual)+  | depth == 0 = refuse (MeasureBudgetExhausted DepthExhausted)+  | leftWidth > budget = Left (SpanRefused (sourceStepIndex step) tLo tMiddle (MeasureBudgetExhausted (BitsExhausted leftWidth)))+  | observed > budget = refuse (MeasureBudgetExhausted (BitsExhausted observed))+  | lengthEnclosureUpper middle <= target =+      bisect inverse step (depth - 1) splitPoint tMiddle tHi right middle after+  | lengthEnclosureLower middle >= target =+      bisect inverse step (depth - 1) from tLo tMiddle left before middle+  | middleResidual <= limit =+      Right (ArcSample (trailSite source step tMiddle splitPoint) tMiddle tMiddle middleResidual)+  | otherwise = refuse (AmbiguousDistance middleResidual)+ where+  refuse :: MeasureObligation -> Either MeasureError ArcSample+  refuse = Left . SpanRefused (sourceStepIndex step) tLo tHi+  width = spanBits from tLo tHi piece+  -- Every parameter of the bracket lies between the bracket's arc distances,+  -- which differ by at most the piece's control polygon.+  piecePolygon = controlPolygon precision piece+  pieceBits = enclosureBits piecePolygon+  residual = min (lengthEnclosureUpper piecePolygon)+    (max (target - lengthEnclosureLower before) (lengthEnclosureUpper after - target))+  (left, right) = splitStep unitHalf piece+  tMiddle = unitMidpoint tLo tHi+  splitPoint = translateExactPoint from (curveStepEnd left)+  leftWidth = spanBits from tLo tMiddle left+  leftChord = chordLength precision left+  leftPolygon = controlPolygon precision left+  middle = before <> enclosureBetween leftChord leftPolygon+  observed = max (enclosureBits leftChord) (max (enclosureBits leftPolygon) (enclosureBits middle))+  middleResidual = min (lengthEnclosureUpper piecePolygon)+    (max (target - lengthEnclosureLower middle) (lengthEnclosureUpper middle - target))++spanAfter :: MeasuredSpan -> LengthEnclosure+spanAfter (MeasuredSpan leaf before) = before <> leafLength leaf++leafLength :: Leaf -> LengthEnclosure+leafLength (Leaf _ _ _ _ _ enclosure) = enclosure++-- | The first element satisfying a predicate that is monotone along the+-- sequence, by bisection.+firstMonotone :: (a -> Bool) -> Seq a -> Maybe a+firstMonotone holds items =+  let (before, rest) = Seq.splitAt (Seq.length items `div` 2) items+   in case Seq.viewl rest of+        EmptyL -> Nothing+        middle :< after+          | holds middle -> firstMonotone holds before <|> Just middle+          | otherwise -> firstMonotone holds after++chordLength :: RadicalPrecision -> CurveStep -> LengthEnclosure+chordLength precision step = euclideanLengthEnclosure precision [coordinates (curveStepEnd step)]++controlPolygon :: RadicalPrecision -> CurveStep -> LengthEnclosure+controlPolygon precision step =+  euclideanLengthEnclosure precision (zipWith edge controls (drop 1 controls))+ where+  controls = toList (stepControlPoints step)+  edge (ExactVector ax ay) (ExactVector bx by) = (bx - ax, by - ay)++coordinates :: ExactVector -> (ExactRational, ExactRational)+coordinates (ExactVector x y) = (x, y)++admitBits :: Int -> (MeasureObligation -> MeasureError) -> Int -> Either MeasureError ()+admitBits budget refuse width = when (width > budget) (Left (refuse (MeasureBudgetExhausted (BitsExhausted width))))++admitEnclosure :: Int -> (MeasureObligation -> MeasureError) -> LengthEnclosure -> Either MeasureError ()+admitEnclosure budget refuse = admitBits budget refuse . enclosureBits++enclosureBits :: LengthEnclosure -> Int+enclosureBits enclosure =+  max (exactRationalBitWidth (lengthEnclosureLower enclosure)) (exactRationalBitWidth (lengthEnclosureUpper enclosure))

@@ -0,0 +1,485 @@+-- | Bounded distance and clearance between two curves, in the coordinates of+-- the submitted curves. Distance and contact are separate obligations: a+-- distance enclosure never implies contact, and contact is certified only by+-- an exact common point or a certified crossing. Proximity certifies "within+-- a distance", never "exactly on", except at evaluated rational sites.+--+-- The search is best-first over pairs of source spans, one from each curve,+-- in exact rational arithmetic. A pair's lower bound is the squared+-- distance between its pieces' control hulls, since a positive-weight piece+-- lies in the convex hull of its controls. The upper bound is the+-- least squared distance between evaluated sites: every piece's endpoints,+-- whose points are those of exact subdivision, and on a straight piece the+-- nearest point to the other piece's endpoints, at its rational parameter. A+-- pair whose lower bound exceeds the upper bound is dropped, since the+-- minimum does not lie there; a pair of two stationary pieces is exact and+-- kept only as sites. The pair with the least lower bound is refined by+-- halving its larger piece. The one square root is taken when an enclosure+-- is reported.+--+-- The pairs left live are candidates: several stay several, and none is+-- claimed to hold a unique nearest point. The subdivision budget bounds+-- depth below any source step and the pairs evaluated in all, and its bits+-- bound every exact value retained or compared, each admitted before it is:+-- the threshold and its square; every span, located controls included, so+-- every endpoint site; every projected site, site displacement and its+-- square, hull gap and its square; every crossing certificate, admitted+-- where it is made; and both ends of every root enclosure, as Measure admits+-- its enclosures. A projected site, being optional, is dropped when too wide;+-- anything else too wide refuses. The radical precision bounds only the+-- reported enclosure.+module Moonlight.Planar.Curve.Proximity+  ( CurveSpan+  , curveSpanSource+  , curveSpanStep+  , curveSpanFrom+  , curveSpanTo+  , ProximityCandidate+  , candidateFirst+  , candidateSecond+  , DistanceObservation+  , distanceBounds+  , distanceWitness+  , distanceCandidates+  , ProximityObligation (..)+  , ProximityError (..)+  , curveDistance+  , ContactWitness (..)+  , ClearanceVerdict (..)+  , clearance+  ) where++import Control.DeepSeq (NFData (..))+import Control.Monad (foldM)+import Data.Either (isRight)+import Data.Foldable (toList, traverse_)+import qualified Data.List.NonEmpty as NonEmpty+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Maybe (mapMaybe)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Moonlight.Planar.Curve+  ( CurveShapeView (..), Subpath (..), curveStepEnd, curveStepShape, shapeView )+import Moonlight.Planar.Curve.Measure+  ( Distance, MeasurePolicy, distanceValue, measureBudget, measurePrecision, measureTolerance )+import Moonlight.Planar.Exact+  ( ExactBounds, ExactPoint, ExactRational, ExactVector (..), UnitInterval, boundsMaximumX+  , boundsMaximumY, boundsMinimumX, boundsMinimumY, exactPointBitWidth, exactPointCoordinates+  , exactPointsBounds, exactRationalBitWidth, positiveExact, positiveExactValue, translateExactPoint+  , unitIntervalValue )+import Moonlight.Planar.Internal.CurveBudget+  ( BudgetObligation (..), SubdivisionBudget, budgetBits, budgetDepth, budgetLeaves )+import Moonlight.Planar.Internal.CurveCertificate+  ( CrossingCertificate, CrossingVerdict (..), crossingVerdict, hullGap, stationaryPiece )+import Moonlight.Planar.Internal.CurveSource+  ( SourceSpan, TrailSite, admitSpan, halveSpan, sitePoint, sourceSpanControls, sourceSpanFrom, sourceSpanPiece+  , sourceSpanStart, sourceSpanStep, sourceSpanTo, sourceStepIndex, sourceSteps, trailSite, wholeSpan )+import Moonlight.Planar.Internal.ExactRational (divideByPositive, unitBetween, unitClamp)+import Moonlight.Planar.Internal.Length+  ( LengthEnclosure, RadicalPrecision, enclosureBetween, euclideanLengthEnclosure+  , lengthEnclosureLower, lengthEnclosureUpper, lengthEnclosureWidth )++-- | A bracket of one source step of a curve: the source, the step's index+-- among its steps ('closedTrailSteps' order for a closed trail), and the+-- bracket in that step's parameter.+data CurveSpan = CurveSpan !Subpath !SourceSpan+  deriving stock (Eq, Show)++instance NFData CurveSpan where+  rnf (CurveSpan source span') = rnf source `seq` rnf span'++curveSpanSource :: CurveSpan -> Subpath+curveSpanSource (CurveSpan source _) = source++curveSpanStep :: CurveSpan -> Int+curveSpanStep (CurveSpan _ span') = sourceStepIndex (sourceSpanStep span')++curveSpanFrom :: CurveSpan -> UnitInterval+curveSpanFrom (CurveSpan _ span') = sourceSpanFrom span'++curveSpanTo :: CurveSpan -> UnitInterval+curveSpanTo (CurveSpan _ span') = sourceSpanTo span'++-- | A live pair of spans, one on each curve, whose lower bound does not+-- exceed the distance found: the minimum may lie there.+data ProximityCandidate = ProximityCandidate !CurveSpan !CurveSpan+  deriving stock (Eq, Show)++instance NFData ProximityCandidate where+  rnf (ProximityCandidate first second) = rnf first `seq` rnf second++candidateFirst :: ProximityCandidate -> CurveSpan+candidateFirst (ProximityCandidate first _) = first++candidateSecond :: ProximityCandidate -> CurveSpan+candidateSecond (ProximityCandidate _ second) = second++-- | The distance between the curves lies in the enclosure, whose width is at+-- most the policy tolerance; the two sites, one on each curve, are as far+-- apart as its upper end allows.+data DistanceObservation = DistanceObservation !LengthEnclosure !TrailSite !TrailSite !(Seq ProximityCandidate)+  deriving stock (Eq, Show)++instance NFData DistanceObservation where+  rnf (DistanceObservation enclosure first second candidates) =+    rnf enclosure `seq` rnf first `seq` rnf second `seq` rnf candidates++distanceBounds :: DistanceObservation -> LengthEnclosure+distanceBounds (DistanceObservation enclosure _ _ _) = enclosure++distanceWitness :: DistanceObservation -> (TrailSite, TrailSite)+distanceWitness (DistanceObservation _ first second _) = (first, second)++distanceCandidates :: DistanceObservation -> Seq ProximityCandidate+distanceCandidates (DistanceObservation _ _ _ candidates) = candidates++-- | Why a distance was not enclosed within the tolerance: the subdivision+-- budget, or, carrying the enclosure's rounding and the tolerance, a radical+-- precision too coarse for the tolerance however far the search refines.+data ProximityObligation+  = ProximityBudgetExhausted !BudgetObligation+  | ProximityPrecisionExhausted !ExactRational !ExactRational+  deriving stock (Eq, Show)++-- | A curve with no steps has no span to measure from. A clearance threshold+-- or its square wider than the bit budget is refused on entry. Step pairs,+-- first curve's steps by second's, more than the leaf budget are refused+-- from the two counts alone, before any source is admitted or pair built. A+-- source step whose start, controls or weights, relative or located, exceed+-- the bit budget is refused before any pair is evaluated. A value wider than the bit budget+-- met before any enclosure is admitted, or in the enclosure a result would+-- report, is refused with no enclosure. Otherwise a refused distance carries+-- the last enclosure admitted and the live candidates there.+data ProximityError+  = EmptyProximitySource+  | ProximityRequestRefused !ProximityObligation+  | ProximitySourceRefused !CurveSpan !BudgetObligation+  | ProximityStepPairsRefused !Int !Int+  | ProximityUnenclosed !ProximityObligation+  | ProximityRefused !ProximityObligation !LengthEnclosure !(Seq ProximityCandidate)+  deriving stock (Eq, Show)++-- | Why clearance fails: two evaluated sites no farther apart than the+-- threshold, one on each curve; one exact point on both curves; or a+-- certified single transversal crossing of two spans, whose point, algebraic+-- in general, is not given.+data ContactWitness+  = CloserThan !TrailSite !TrailSite+  | SharedPoint !TrailSite !TrailSite+  | TransversalCrossing !CurveSpan !CurveSpan !CrossingCertificate+  deriving stock (Eq, Show)++instance NFData ContactWitness where+  rnf (CloserThan first second) = rnf first `seq` rnf second+  rnf (SharedPoint first second) = rnf first `seq` rnf second+  rnf (TransversalCrossing first second certificate) = rnf first `seq` rnf second `seq` rnf certificate++-- | Clearance at a threshold @d@ is strict: it holds when the distance+-- exceeds @d@, so at zero it holds exactly when the curves are disjoint. It+-- is violated, with a witness, when the distance is at most @d@. Otherwise+-- the budget ran out first, with the enclosure and candidates reached; a+-- tangency at a parameter subdivision never reaches, or a distance of+-- exactly @d@ approached from above, never resolves. Enclosures are reported+-- at the policy's precision and are not bound by its tolerance.+data ClearanceVerdict+  = ClearanceHolds !LengthEnclosure+  | ClearanceViolated !ContactWitness+  | ClearanceUnresolved !LengthEnclosure !(Seq ProximityCandidate) !BudgetObligation+  deriving stock (Eq, Show)++instance NFData ClearanceVerdict where+  rnf (ClearanceHolds enclosure) = rnf enclosure+  rnf (ClearanceViolated witness) = rnf witness+  rnf (ClearanceUnresolved enclosure candidates obligation) =+    rnf enclosure `seq` rnf candidates `seq` rnf obligation++-- | The distance between two curves within the policy tolerance. Exhaustion+-- refuses; a success is never wider than the tolerance.+curveDistance :: MeasurePolicy -> Subpath -> Subpath -> Either ProximityError DistanceObservation+curveDistance policy first second = startSearch False budget first second >>= search Nothing+ where+  budget = measureBudget policy+  precision = measurePrecision policy+  tolerance = positiveExactValue (measureTolerance policy)+  -- The last admitted enclosure and its candidates, when there is one.+  search+    :: Maybe (LengthEnclosure, Seq ProximityCandidate) -> Search -> Either ProximityError DistanceObservation+  search admitted reached@(Search frontier (Nearest _ _ siteA siteB) _ _ _ _) =+    case enclosed budget precision reached of+      Left obligation -> Left (refusal (ProximityBudgetExhausted obligation) admitted)+      Right (lower, upper)+        | lengthEnclosureWidth reached' <= tolerance -> Right (DistanceObservation reached' siteA siteB candidates)+        | otherwise -> case Map.minViewWithKey frontier of+            -- Refinement narrows a geometric gap; once rounding alone exceeds+            -- the tolerance, or the bounds are exact, it cannot help.+            Just ((_, (_, pair)), rest)+              | optimisticGap > tolerance || rounding <= tolerance ->+                  either+                    (\(obligation, _) -> Left (refusal (ProximityBudgetExhausted obligation) here))+                    (search here)+                    (refine budget reached rest pair)+            _ -> Left (refusal (ProximityPrecisionExhausted rounding tolerance) here)+       where+        reached' = enclosureBetween lower upper+        candidates = liveCandidates reached+        here = Just (reached', candidates)+        optimisticGap = lengthEnclosureLower upper - lengthEnclosureUpper lower+        rounding = lengthEnclosureWidth lower + lengthEnclosureWidth upper+  refusal :: ProximityObligation -> Maybe (LengthEnclosure, Seq ProximityCandidate) -> ProximityError+  refusal obligation = maybe (ProximityUnenclosed obligation) (uncurry (ProximityRefused obligation))++-- | Strict clearance at the threshold between two curves.+clearance :: MeasurePolicy -> Distance -> Subpath -> Subpath -> Either ProximityError ClearanceVerdict+clearance policy threshold first second = do+  -- The threshold before its square, so an over-wide threshold is never squared.+  either (Left . ProximityRequestRefused . ProximityBudgetExhausted) Right+    (admitWidth budget (exactRationalBitWidth level) *> admitWidth budget (exactRationalBitWidth limit))+  startSearch True budget first second >>= decide+ where+  budget = measureBudget policy+  precision = measurePrecision policy+  level = distanceValue threshold+  limit = level * level+  decide :: Search -> Either ProximityError ClearanceVerdict+  decide reached@(Search frontier (Nearest squared _ siteA siteB) crossing _ _ _)+    | squared == 0 = Right (ClearanceViolated (SharedPoint siteA siteB))+    | squared <= limit = Right (ClearanceViolated (CloserThan siteA siteB))+    | Just (spanA, spanB, certificate) <- crossing = Right (ClearanceViolated (TransversalCrossing spanA spanB certificate))+    | otherwise = case Map.minViewWithKey frontier of+        Just (((gap, _), (_, pair)), rest) | gap <= limit ->+          either+            (\(obligation, _) -> (\enclosure -> ClearanceUnresolved enclosure (liveCandidates reached) obligation) <$> report reached)+            decide (refine budget reached rest pair)+        -- No live pair lies within the threshold.+        _ -> ClearanceHolds <$> report reached+  report :: Search -> Either ProximityError LengthEnclosure+  report reached =+    either (Left . ProximityUnenclosed . ProximityBudgetExhausted) (Right . uncurry enclosureBetween)+      (enclosed budget precision reached)++-- A piece of one curve: its depth below its source step, its source, its+-- span, and its control box, whose larger side picks the piece to halve.+data Piece = Piece !Int !Subpath !SourceSpan !ExactBounds++data Pair = Pair !Piece !Piece++-- A pair of evaluated sites, one on each curve, with their squared distance+-- and displacement.+data Nearest = Nearest !ExactRational !ExactVector !TrailSite !TrailSite++-- The live pairs keyed by squared gap and admission ordinal, each with its+-- gap displacement; the nearest sites; the first certified crossing, when+-- crossings are watched; the pairs evaluated; and whether crossings are+-- watched.+data Search = Search+  !(Map (ExactRational, Int) (ExactVector, Pair)) !Nearest+  !(Maybe (CurveSpan, CurveSpan, CrossingCertificate)) !Int !Int !Bool++-- Every step pair, evaluated in order. The pair count is decided from the+-- two step counts, their exact product against the leaf budget, before any+-- source is admitted or any pair is built; an empty curve's product is zero.+startSearch :: Bool -> SubdivisionBudget -> Subpath -> Subpath -> Either ProximityError Search+startSearch watching budget first second+  | toInteger countA * toInteger countB > toInteger (budgetLeaves budget) =+      Left (ProximityStepPairsRefused countA countB)+  | otherwise = do+      piecesA <- traverse (admitSource budget) (sourcePieces first)+      piecesB <- traverse (admitSource budget) (sourcePieces second)+      case (piecesA, piecesB) of+        (a : _, b : _) -> either (Left . ProximityUnenclosed . ProximityBudgetExhausted) Right $ do+          nearest :| _ <- pairSites budget (Pair a b)+          foldM (enter budget) (Search Map.empty nearest Nothing 0 0 watching)+            [Pair pieceA pieceB | pieceA <- piecesA, pieceB <- piecesB]+        _ -> Left EmptyProximitySource+ where+  countA = Seq.length (sourceSteps first)+  countB = Seq.length (sourceSteps second)++-- Halve the pair's larger refinable piece and admit both children. A refusal+-- keeps the search as it was, the pair still live.+refine+  :: SubdivisionBudget -> Search -> Map (ExactRational, Int) (ExactVector, Pair) -> Pair+  -> Either (BudgetObligation, Search) Search+refine budget reached rest pair =+  either (\obligation -> Left (obligation, reached)) Right $ do+    children <- split budget pair+    foldM (admit budget) (withFrontier rest reached) children++admit :: SubdivisionBudget -> Search -> Pair -> Either BudgetObligation Search+admit budget reached@(Search _ _ _ spent _ _) pair+  | spent >= budgetLeaves budget = Left LeavesExhausted+  | otherwise = enter budget reached pair++-- Evaluate a pair: its sites may improve the nearest, which prunes every+-- pair whose gap now exceeds it; the pair stays live if its gap does not and+-- one of its pieces can move; a watched crossing is recorded once. Every+-- value retained or compared is admitted first.+enter :: SubdivisionBudget -> Search -> Pair -> Either BudgetObligation Search+enter budget (Search frontier nearest crossing spent ordinal watching) pair = do+  sites <- pairSites budget pair+  (gapVector, gap) <- pairGap budget pair+  let nearest' = foldl' closer nearest sites+      bound = nearestSquared nearest'+      kept+        | gap <= bound && refinable pair = Map.insert (gap, ordinal) (gapVector, pair) frontier+        | otherwise = frontier+  crossing' <- case crossing of+    Nothing | watching && gap == 0 -> pairCrossing budget pair+    _ -> Right crossing+  pure (Search (Map.takeWhileAntitone ((<= bound) . fst) kept) nearest' crossing' (spent + 1) (ordinal + 1) watching)++withFrontier :: Map (ExactRational, Int) (ExactVector, Pair) -> Search -> Search+withFrontier frontier (Search _ nearest crossing spent ordinal watching) =+  Search frontier nearest crossing spent ordinal watching++split :: SubdivisionBudget -> Pair -> Either BudgetObligation [Pair]+split budget (Pair a b)+  | refinable' a && (not (refinable' b) || extent a >= extent b) =+      (\(left, right) -> [Pair left b, Pair right b]) <$> halve budget a+  | refinable' b = (\(left, right) -> [Pair a left, Pair a right]) <$> halve budget b+  | otherwise = Left DepthExhausted+ where+  refinable' piece'@(Piece depth _ _ _) = moving piece' && depth < budgetDepth budget++halve :: SubdivisionBudget -> Piece -> Either BudgetObligation (Piece, Piece)+halve budget (Piece depth source span' _) = do+  let (left, right) = halveSpan span'+  traverse_ (admitSpan budget) [left, right]+  pure (piece (depth + 1) source left, piece (depth + 1) source right)++admitSource :: SubdivisionBudget -> Piece -> Either ProximityError Piece+admitSource budget source@(Piece _ subpath span' _) =+  either (Left . ProximitySourceRefused (CurveSpan subpath span')) (const (Right source)) (admitSpan budget span')++sourcePieces :: Subpath -> [Piece]+sourcePieces source = [piece 0 source (wholeSpan step) | step <- toList (sourceSteps source)]++piece :: Int -> Subpath -> SourceSpan -> Piece+piece depth source span' = Piece depth source span' (exactPointsBounds (sourceSpanControls span'))++moving :: Piece -> Bool+moving (Piece _ _ span' _) = not (stationaryPiece (sourceSpanPiece span'))++refinable :: Pair -> Bool+refinable (Pair a b) = moving a || moving b++extent :: Piece -> ExactRational+extent (Piece _ _ _ box) = max (boundsMaximumX box - boundsMinimumX box) (boundsMaximumY box - boundsMinimumY box)++-- The shortest displacement between two pieces' control hulls, zero where+-- they meet, and its square, admitted. Each piece lies in its hull, so the+-- square bounds the pair's squared distance from below; unlike the control+-- boxes, the hulls of two concentric arcs close on the arcs quadratically.+pairGap :: SubdivisionBudget -> Pair -> Either BudgetObligation (ExactVector, ExactRational)+pairGap budget (Pair (Piece _ _ spanA _) (Piece _ _ spanB _)) =+  (gap, squared) <$ admitWidth budget (max (vectorBits gap) (exactRationalBitWidth squared))+ where+  gap = hullGap (sourceSpanControls spanA) (sourceSpanControls spanB)+  squared = dot gap gap++-- A certified crossing, its certificate admitted by 'crossingVerdict'.+pairCrossing :: SubdivisionBudget -> Pair -> Either BudgetObligation (Maybe (CurveSpan, CurveSpan, CrossingCertificate))+pairCrossing budget (Pair (Piece _ sourceA spanA _) (Piece _ sourceB spanB _)) =+  fmap single (crossingVerdict budget (sourceSpanStart spanA) (sourceSpanPiece spanA) (sourceSpanStart spanB) (sourceSpanPiece spanB))+ where+  single verdict = case verdict of+    Just (SingleCrossing certificate) -> Just (CurveSpan sourceA spanA, CurveSpan sourceB spanB, certificate)+    _ -> Nothing++-- Every endpoint pairing, and each endpoint's nearest point on the other+-- piece when that piece is straight. An endpoint site is a located control+-- of an admitted span; the pairings are admitted or refuse, and a projected+-- pairing too wide is dropped.+pairSites :: SubdivisionBudget -> Pair -> Either BudgetObligation (NonEmpty Nearest)+pairSites budget (Pair a b) = do+  corners <- traverse (admitNearest budget) (sitePair <$> ends a <*> ends b)+  let projected =+        mapMaybe (\siteB -> (`sitePair` siteB) <$> projection budget a (sitePoint siteB)) (toList (ends b))+          <> mapMaybe (\siteA -> sitePair siteA <$> projection budget b (sitePoint siteA)) (toList (ends a))+  pure (NonEmpty.appendList corners (filter (isRight . admitNearest budget) projected))++admitNearest :: SubdivisionBudget -> Nearest -> Either BudgetObligation Nearest+admitNearest budget near@(Nearest squared gap _ _) =+  near <$ admitWidth budget (max (vectorBits gap) (exactRationalBitWidth squared))++-- A piece's two endpoint sites, at the points of its exact subdivision.+ends :: Piece -> NonEmpty TrailSite+ends (Piece _ source span' _) =+  trailSite source step (sourceSpanFrom span') start+    :| [trailSite source step (sourceSpanTo span') (translateExactPoint start (curveStepEnd (sourceSpanPiece span')))]+ where+  step = sourceSpanStep span'+  start = sourceSpanStart span'++-- The nearest point of a straight piece to a point, as a site. A straight+-- piece is its step restricted to its bracket, affinely in the parameter, so+-- the piece's fraction @t@ is the step's parameter a fraction @t@ through the+-- bracket, and the point there is the step's. A site wider than the bit+-- budget is not retained.+projection :: SubdivisionBudget -> Piece -> ExactPoint -> Maybe TrailSite+projection budget (Piece _ source span' _) point = case shapeView (curveStepShape (sourceSpanPiece span')) of+  LinearView -> do+    squaredLength <- either (const Nothing) Just (positiveExact (dot direction direction))+    let fraction = unitClamp (divideByPositive (dot (displacement start point) direction) squaredLength)+        nearest = translateExactPoint start (scale (unitIntervalValue fraction) direction)+        parameter = unitBetween (sourceSpanFrom span') (sourceSpanTo span') fraction+    if max (exactPointBitWidth nearest) (exactRationalBitWidth (unitIntervalValue parameter)) <= budgetBits budget+      then Just (trailSite source (sourceSpanStep span') parameter nearest)+      else Nothing+  _ -> Nothing+ where+  start = sourceSpanStart span'+  direction = curveStepEnd (sourceSpanPiece span')++sitePair :: TrailSite -> TrailSite -> Nearest+sitePair siteA siteB = Nearest (dot gap gap) gap siteA siteB+ where+  gap = displacement (sitePoint siteA) (sitePoint siteB)++closer :: Nearest -> Nearest -> Nearest+closer current candidate+  | nearestSquared candidate < nearestSquared current = candidate+  | otherwise = current++nearestSquared :: Nearest -> ExactRational+nearestSquared (Nearest squared _ _ _) = squared++-- Root enclosures of the least live gap and of the nearest distance, both+-- ends of each admitted as Measure admits its enclosures.+enclosed :: SubdivisionBudget -> RadicalPrecision -> Search -> Either BudgetObligation (LengthEnclosure, LengthEnclosure)+enclosed budget precision (Search frontier (Nearest _ gap _ _) _ _ _ _) =+  (lower, upper) <$ traverse_ (admitWidth budget . enclosureBits) [lower, upper]+ where+  upper = root gap+  lower = maybe upper (root . fst . snd) (Map.lookupMin frontier)+  root (ExactVector x y) = euclideanLengthEnclosure precision [(x, y)]+  enclosureBits enclosure =+    max (exactRationalBitWidth (lengthEnclosureLower enclosure)) (exactRationalBitWidth (lengthEnclosureUpper enclosure))++admitWidth :: SubdivisionBudget -> Int -> Either BudgetObligation ()+admitWidth budget width+  | width > budgetBits budget = Left (BitsExhausted width)+  | otherwise = Right ()++vectorBits :: ExactVector -> Int+vectorBits (ExactVector x y) = max (exactRationalBitWidth x) (exactRationalBitWidth y)++liveCandidates :: Search -> Seq ProximityCandidate+liveCandidates (Search frontier _ _ _ _ _) =+  Seq.fromList+    [ ProximityCandidate (CurveSpan sourceA spanA) (CurveSpan sourceB spanB)+    | (_, Pair (Piece _ sourceA spanA _) (Piece _ sourceB spanB _)) <- Map.elems frontier ]++displacement :: ExactPoint -> ExactPoint -> ExactVector+displacement from to =+  let (ax, ay) = exactPointCoordinates from+      (bx, by) = exactPointCoordinates to+   in ExactVector (bx - ax) (by - ay)++dot :: ExactVector -> ExactVector -> ExactRational+dot (ExactVector ax ay) (ExactVector bx by) = ax * bx + ay * by++scale :: ExactRational -> ExactVector -> ExactVector+scale factor (ExactVector x y) = ExactVector (factor * x) (factor * y)

@@ -1,19 +1,82 @@ {-# LANGUAGE DerivingStrategies #-} --- | Explicit simple outer/hole assembly of approximated curves. Admission--- proves polygon topology only, never topology equivalence with the curves.+-- | Simple outer/hole assembly of closed curves, certified. A region is+-- lowered only after its curves are proved simple, pairwise disjoint and+-- wound as their roles say, and its polygon is admitted only when the+-- lowered loops nest as the curves do. The certificate reads exact+-- predicates on control points alone, never the lowering's metric.+--+-- The domain is four predicates within a finite subdivision budget. D1:+-- every piece strictly advances along some direction. D2: at every joint,+-- with stationary steps contracted, the incoming piece lies ahead of the+-- joint and the outgoing piece behind it along one direction. D3: every+-- other pair of pieces, in one contour or two, has disjoint control hulls or+-- a certified absence of crossing. Under D1 to D3 the straight-line homotopy+-- of every piece to its chord is an isotopy of the whole configuration that+-- fixes the piece endpoints: each contour is simple, the contours are+-- pairwise disjoint, a contour's winding is its chord polygon's, and a point+-- outside every piece's control hull lies inside a contour exactly when it+-- lies inside that contour's chord polygon. D4: the admitted polygon's loops+-- are pairwise boundary-disjoint and each lies inside another exactly when+-- its curve does.+--+-- Outside the domain it refuses: with the certified contact or crossing+-- when one is found, and otherwise with the unresolved obligation and the+-- budget it spent. Contact is certified only at a source step's own+-- endpoint, where the point is exact and on both curves; any other tangency+-- is never certified either way. module Moonlight.Planar.Curve.Region   ( CurveComponent (..)+  , ContourRole (..)+  , ContourRef (..)+  , ContourSpan (..)+  , TopologyObstruction (..)   , CurveRegionError (..)+  , SubdivisionBudget+  , SubdivisionBudgetError (..)+  , subdivisionBudget+  , BudgetObligation (..)+  , CrossingCertificate+  , CurveTopologyEvidence+  , certifiedPieceCounts+  , certifiedPointLocation+  , certifySimpleRegion   , lowerSimpleRegion   ) where +import Control.DeepSeq (NFData (..))+import Control.Monad (join, unless, zipWithM) import Data.Bifunctor (first)-import Moonlight.Planar.Curve (ClosedTrail, Located)+import Data.Foldable (toList, traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Maybe (isJust, isNothing, listToMaybe)+import Moonlight.Planar.Curve+  ( ClosedTrail, CurveShapeView (..), CurveStep, Located, Subpath (..), curveStepEnd, curveStepShape+  , shapeView ) import Moonlight.Planar.Curve.Lowering   ( LoweringPolicy, LoweringError, LoweredPath, lowerClosedTrail, loweredPoints )+import Moonlight.Planar.Exact+  ( ExactBounds, ExactPoint, UnitInterval, exactOrient2d, exactPointsBounds, pointInBounds+  , translateExactPoint )+import Moonlight.Planar.Internal.CurveBudget+  ( BudgetObligation (..), SubdivisionBudget, SubdivisionBudgetError (..), budgetDepth+  , budgetLeaves, subdivisionBudget )+import Moonlight.Planar.Internal.CurveCertificate+  ( CrossingCertificate, CrossingVerdict (..), crossingVerdict, hullSeparation, jointWitness+  , monotoneWitness, separatingAxis, stationaryPiece )+import Moonlight.Planar.Internal.CurveSource+  ( SourceSpan, admitSpan, halveSpan, sourceSpanControls, sourceSpanFrom, sourceSpanPiece, sourceSpanStart+  , sourceSpanStep, sourceSpanTo, sourceStepIndex, sourceSteps, wholeSpan )+import Moonlight.Planar.Internal.Region.Bounds (overlappingPairs)+import Moonlight.Planar.Internal.Region.Loop+  ( PreparedLoop, crossLoopRelations, cycleWinding, firstPreparedPoint, pointLocationInCycle, prepareLoop+  , preparedBounds, preparedPointLocation ) import Moonlight.Planar.Region-  ( PlanarRegion, RegionValidationError, exactLoop, polygonComponent, planarRegion )+  ( ExactLoop, PlanarRegion, RegionPointLocation (..), RegionValidationError, exactLoop+  , polygonComponent, planarRegion )  -- | The submitted winding is significant: outer CCW, holes CW. An explicitly -- located closed trail does not by itself claim simplicity or containment.@@ -22,22 +85,119 @@   , curveHoles :: ![Located ClosedTrail]   } +data ContourRole = OuterContour | HoleContour !Int+  deriving stock (Eq, Ord, Show)++-- | A contour by its component's submitted ordinal and its role there.+data ContourRef = ContourRef !Int !ContourRole+  deriving stock (Eq, Ord, Show)++-- | The part of a contour a refusal is about: a source step's index among+-- the closed trail's steps, closing step last, and a bracket in that step's+-- parameter.+data ContourSpan = ContourSpan !ContourRef !Int !UnitInterval !UnitInterval+  deriving stock (Eq, Show)++-- | Why a region's curves are outside the certified domain.+data TopologyObstruction+  = DegenerateContour !ContourRef+    -- ^ Every step of the contour is stationary.+  | SourceSpanRefused !ContourSpan !BudgetObligation+    -- ^ The source steps themselves exceed the budget.+  | UnresolvedMonotonicity !ContourSpan !BudgetObligation+  | UnseparatedJoin !ContourSpan !ContourSpan !BudgetObligation+    -- ^ The incoming and outgoing spans at a joint.+  | CertifiedContact !ContourSpan !ContourSpan !ExactPoint+    -- ^ Two non-adjacent source steps meet at an exact point on both: an+    -- endpoint of each, or an endpoint of one on the other, a line.+  | UnresolvedContact !ContourSpan !ContourSpan !BudgetObligation+  | CertifiedSelfCrossing !ContourSpan !ContourSpan !CrossingCertificate+  | CertifiedContourCrossing !ContourSpan !ContourSpan !CrossingCertificate+  | ContourWindingRefused !ContourRef !Ordering+    -- ^ A certified simple contour whose winding is not its role's. Under D1+    -- to D3 the isotopy to the chords keeps the contour simple, so its chord+    -- polygon is simple and carries the curve's winding.+  | PolygonTopologyDiffers !ContourRef !ContourRef+    -- ^ The two lowered loops touch, or the first lies inside the second,+    -- where the curves do not, or the reverse.+  deriving stock (Eq, Show)+ data CurveRegionError-  = CurveLoweringRefused !LoweringError+  = CurveTopologyRefused !TopologyObstruction+  | CurveLoweringRefused !LoweringError   | CurvePolygonRefused !RegionValidationError   deriving stock (Eq, Show) --- | The lowering policy's leaf budget applies per contour. Receipts remain in--- submitted component/outer/hole order, independently of polygon canonicalization.--- Coordinates remain source-local; the policy's affine map only measures error.+-- | What certification proved about a region's curves, observed only through+-- the questions it answers exactly.+newtype CurveTopologyEvidence = CurveTopologyEvidence [CertifiedContour]++instance NFData CurveTopologyEvidence where+  rnf (CurveTopologyEvidence contours) = rnf contours++-- | A certified contour's chord cycle, anchor first, and its pieces' control+-- hulls.+data CertifiedContour = CertifiedContour !ContourRef !(NonEmpty ExactPoint) ![PieceHull]++instance NFData CertifiedContour where+  rnf (CertifiedContour ref chord hulls) = ref `seq` rnf chord `seq` rnf hulls++data PieceHull = PieceHull !ExactBounds !(NonEmpty ExactPoint)++instance NFData PieceHull where+  rnf (PieceHull bounds hull) = bounds `seq` rnf hull++-- | Each contour's certified piece count, in submitted order.+certifiedPieceCounts :: CurveTopologyEvidence -> [(ContourRef, Int)]+certifiedPieceCounts (CurveTopologyEvidence contours) =+  [(ref, length hulls) | CertifiedContour ref _ hulls <- contours]++-- | Where a point lies in the curves' region, when it lies strictly outside+-- every piece's control hull; the region is each component's outer contour+-- less its holes. Nearer the curves than that, it is not decided.+certifiedPointLocation :: CurveTopologyEvidence -> ExactPoint -> Maybe RegionPointLocation+certifiedPointLocation (CurveTopologyEvidence contours) point+  | any touchesHull [hull | CertifiedContour _ _ hulls <- contours, hull <- hulls] = Nothing+  | any outerWithoutHole inside = Just RegionInterior+  | otherwise = Just RegionExterior+ where+  touchesHull (PieceHull bounds hull) =+    pointInBounds point bounds && isNothing (separatingAxis (point :| []) hull)+  inside = [ref | CertifiedContour ref chord _ <- contours, pointLocationInCycle chord point == RegionInterior]+  outerWithoutHole (ContourRef component role) =+    role == OuterContour && not (any (\(ContourRef other otherRole) -> other == component && otherRole /= OuterContour) inside)++-- | Certify the region's curves: D1 to D3 and each contour's winding. The+-- budget bounds the whole region: depth below any source step, pieces over+-- all contours, and the bits of every piece, located controls included, and+-- of every crossing certificate, each admitted where it is made.+certifySimpleRegion+  :: SubdivisionBudget -> [CurveComponent] -> Either TopologyObstruction CurveTopologyEvidence+certifySimpleRegion budget components = do+  initial <- traverse (uncurry (initialContour budget)) (contourTrails components)+  case drop (budgetLeaves budget) [contourSpan ref sourceSpan | Contour ref pieces <- initial, Piece _ sourceSpan <- toList pieces] of+    extra : _ -> Left (SourceSpanRefused extra LeavesExhausted)+    [] -> Right ()+  traverse_ endpointContact (overlappingPairs placedBounds (concat (zipWith placeContour [0 ..] initial)))+  certified <- refineUntilCertified budget initial+  CurveTopologyEvidence <$> traverse certifiedContour certified++-- | Certify, lower each contour under the policy, admit the polygon region,+-- and check D4 on its loops. Receipts remain in submitted component, outer,+-- hole order, independently of polygon canonicalization. Coordinates remain+-- source-local; the policy's affine map only measures error, and its leaf+-- budget applies per contour. lowerSimpleRegion   :: LoweringPolicy+  -> SubdivisionBudget   -> [CurveComponent]-  -> Either CurveRegionError (PlanarRegion, [LoweredPath])-lowerSimpleRegion policy components = do+  -> Either CurveRegionError (PlanarRegion, [LoweredPath], CurveTopologyEvidence)+lowerSimpleRegion policy budget components = do+  evidence@(CurveTopologyEvidence contours) <- first CurveTopologyRefused (certifySimpleRegion budget components)   admitted <- traverse lowerComponent components-  region <- first CurvePolygonRefused (planarRegion (map fst admitted))-  pure (region, concatMap snd admitted)+  region <- first CurvePolygonRefused (planarRegion [component | (component, _, _) <- admitted])+  loopsAgree contours (concat [loops | (_, _, loops) <- admitted])+  pure (region, concat [paths | (_, paths, _) <- admitted], evidence)  where   lowerComponent (CurveComponent outer holes) = do     outerPath <- first CurveLoweringRefused (lowerClosedTrail policy outer)@@ -45,4 +205,215 @@     outerLoop <- first CurvePolygonRefused (exactLoop (loweredPoints outerPath))     holeLoops <- traverse (first CurvePolygonRefused . exactLoop . loweredPoints) holePaths     component <- first CurvePolygonRefused (polygonComponent outerLoop holeLoops)-    pure (component, outerPath : holePaths)+    pure (component, outerPath : holePaths, outerLoop : holeLoops)++-- D4. Within a component the admitted polygon already has disjoint+-- boundaries, holes inside the outer loop and no hole inside another, so+-- boundary contact is asked only across components; nesting is compared for+-- every ordered pair. With boundaries disjoint, a loop's first point decides+-- whether it lies inside another.+loopsAgree :: [CertifiedContour] -> [ExactLoop] -> Either CurveRegionError ()+loopsAgree contours loops = do+  prepared <- first CurvePolygonRefused (traverse prepareLoop loops)+  let paired = zip contours prepared+  traverse_ disjointBoundaries+    (filter acrossComponents (overlappingPairs (preparedBounds . snd) paired))+  traverse_ sameNesting [(a, b) | a <- paired, b <- paired, certifiedRef (fst a) /= certifiedRef (fst b)]+ where+  acrossComponents :: ((CertifiedContour, PreparedLoop), (CertifiedContour, PreparedLoop)) -> Bool+  acrossComponents ((a, _), (b, _)) = certifiedComponent a /= certifiedComponent b+  disjointBoundaries ((a, loopA), (b, loopB)) = do+    relations <- first CurvePolygonRefused (crossLoopRelations loopA loopB)+    unless (null relations) (differs a b)+  sameNesting ((a, loopA), (b, loopB)) =+    unless+      (curveInside a b == (preparedPointLocation loopB (firstPreparedPoint loopA) == RegionInterior))+      (differs a b)+  differs :: CertifiedContour -> CertifiedContour -> Either CurveRegionError ()+  differs a b = Left (CurveTopologyRefused (PolygonTopologyDiffers (certifiedRef a) (certifiedRef b)))++-- | Whether the first certified contour lies inside the second. Its anchor is+-- a piece endpoint of a contour disjoint from the second's pieces throughout+-- the isotopy, so the second's chord polygon decides, never on its boundary.+curveInside :: CertifiedContour -> CertifiedContour -> Bool+curveInside (CertifiedContour _ (anchor :| _) _) (CertifiedContour _ chord _) =+  pointLocationInCycle chord anchor == RegionInterior++certifiedRef :: CertifiedContour -> ContourRef+certifiedRef (CertifiedContour ref _ _) = ref++certifiedComponent :: CertifiedContour -> Int+certifiedComponent (CertifiedContour (ContourRef component _) _ _) = component++-- A piece of a contour: its depth below its source step and its span.+data Piece = Piece !Int !SourceSpan++-- A contour's pieces in trail order, stationary steps contracted.+data Contour = Contour !ContourRef !(NonEmpty Piece)++-- A piece placed for one round: contour ordinal, position, the contour's+-- piece count, the contour, and the piece.+data Placed = Placed !Int !Int !Int !ContourRef !Piece++-- The refusal a demanded piece reports if the budget stops its halving.+type Refusal = BudgetObligation -> TopologyObstruction++contourTrails :: [CurveComponent] -> [(ContourRef, Located ClosedTrail)]+contourTrails components = concat (zipWith componentContours [0 ..] components)+ where+  componentContours component (CurveComponent outer holes) =+    (ContourRef component OuterContour, outer)+      : zipWith (\hole trail -> (ContourRef component (HoleContour hole), trail)) [0 ..] holes++initialContour+  :: SubdivisionBudget -> ContourRef -> Located ClosedTrail -> Either TopologyObstruction Contour+initialContour budget ref trail = do+  spans <- traverse admit (filter moving (map wholeSpan (toList (sourceSteps (ClosedSubpath trail)))))+  case spans of+    [] -> Left (DegenerateContour ref)+    span0 : rest -> Right (Contour ref (Piece 0 <$> span0 :| rest))+ where+  moving = not . stationaryPiece . sourceSpanPiece+  admit sourceSpan = sourceSpan <$ admitBits budget (SourceSpanRefused (contourSpan ref sourceSpan)) sourceSpan++refineUntilCertified :: SubdivisionBudget -> [Contour] -> Either TopologyObstruction [Contour]+refineUntilCertified budget contours = do+  demands <- roundDemands budget contours+  case Map.minView demands of+    Nothing -> Right contours+    Just (firstRefusal, _) -> do+      refined <- zipWithM (refineContour budget demands) [0 ..] contours+      unless (sum [length pieces | Contour _ pieces <- refined] <= budgetLeaves budget)+        (Left (firstRefusal LeavesExhausted))+      refineUntilCertified budget refined++-- Every piece this round cannot certify, keyed by contour ordinal and+-- position, with the first refusal it met: monotonicity, then joints, then+-- contacts. A certified crossing refuses at once.+roundDemands :: SubdivisionBudget -> [Contour] -> Either TopologyObstruction (Map (Int, Int) Refusal)+roundDemands budget contours = do+  contacts <- concat <$> traverse (contactDemands budget) (overlappingPairs placedBounds (concat placed))+  pure (Map.fromListWith (\_ earlier -> earlier) (monotonicity <> joints <> contacts))+ where+  placed = zipWith placeContour [0 ..] contours+  monotonicity =+    [ (placedKey piece, UnresolvedMonotonicity (placedSpan piece))+    | piece <- concat placed, isNothing (monotoneWitness (placedStep piece)) ]+  joints =+    [ demand+    | pieces <- placed+    , (incoming, outgoing) <- zip pieces (drop 1 pieces <> take 1 pieces)+    , isNothing (jointWitness (placedStep incoming) (placedStep outgoing))+    , let refusal = UnseparatedJoin (placedSpan incoming) (placedSpan outgoing)+    , demand <- [(placedKey incoming, refusal), (placedKey outgoing, refusal)] ]++placeContour :: Int -> Contour -> [Placed]+placeContour ordinal (Contour ref pieces) =+  zipWith (\position piece -> Placed ordinal position count ref piece) [0 ..] (toList pieces)+ where+  count = length pieces++contactDemands :: SubdivisionBudget -> (Placed, Placed) -> Either TopologyObstruction [((Int, Int), Refusal)]+contactDemands budget (a, b)+  | adjacent a b = Right []+  | isJust (hullSeparation startA stepA startB stepB) = Right []+  | otherwise = case crossingVerdict budget startA stepA startB stepB of+      Left obligation -> Left (refusal obligation)+      Right (Just (SingleCrossing certificate)) -> Left (crossing (placedSpan a) (placedSpan b) certificate)+      Right (Just (NoCrossing _)) -> Right []+      Right Nothing -> Right [(placedKey a, refusal), (placedKey b, refusal)]+ where+  startA = placedStart a+  stepA = placedStep a+  startB = placedStart b+  stepB = placedStep b+  refusal = UnresolvedContact (placedSpan a) (placedSpan b)+  crossing+    | placedContour a == placedContour b = CertifiedSelfCrossing+    | otherwise = CertifiedContourCrossing++-- Contact at the source steps' own endpoints, before any refinement: two+-- non-adjacent steps sharing an endpoint, or an endpoint of one on the other+-- when that is a line segment. Endpoints made by halving lie on the other+-- curve only by coincidence, so they are left to the refinement.+endpointContact :: (Placed, Placed) -> Either TopologyObstruction ()+endpointContact (a, b)+  | adjacent a b = Right ()+  | otherwise = maybe (Right ()) (Left . CertifiedContact (placedSpan a) (placedSpan b)) contact+ where+  contact = listToMaybe (filter (`onStep` b) (bothEnds a) <> filter (`onStep` a) (bothEnds b))+  bothEnds :: Placed -> [ExactPoint]+  bothEnds placed = let (start, end) = placedEnds placed in [start, end]++placedEnds :: Placed -> (ExactPoint, ExactPoint)+placedEnds placed = (start, translateExactPoint start (curveStepEnd (placedStep placed)))+ where+  start = placedStart placed++onStep :: ExactPoint -> Placed -> Bool+onStep point placed =+  point == start || point == end+    || (straight && exactOrient2d start end point == EQ && pointInBounds point (exactPointsBounds (start :| [end])))+ where+  (start, end) = placedEnds placed+  straight = case shapeView (curveStepShape (placedStep placed)) of+    LinearView -> True+    _ -> False++adjacent :: Placed -> Placed -> Bool+adjacent a@(Placed contourA positionA _ _ _) b@(Placed contourB positionB _ _ _) =+  contourA == contourB && (positionB == next a || positionA == next b)+ where+  next (Placed _ position count _ _) = (position + 1) `mod` count++refineContour+  :: SubdivisionBudget -> Map (Int, Int) Refusal -> Int -> Contour -> Either TopologyObstruction Contour+refineContour budget demands ordinal (Contour ref pieces) =+  Contour ref . join <$> traverse refine (NonEmpty.zip (0 :| [1 ..]) pieces)+ where+  refine (position, piece@(Piece depth sourceSpan)) = case Map.lookup (ordinal, position) demands of+    Nothing -> Right (piece :| [])+    Just refusal+      | depth >= budgetDepth budget -> Left (refusal DepthExhausted)+      | otherwise -> do+          let (left, right) = halveSpan sourceSpan+          traverse_ (admitBits budget refusal) [left, right]+          Right (Piece (depth + 1) left :| [Piece (depth + 1) right])++admitBits :: SubdivisionBudget -> Refusal -> SourceSpan -> Either TopologyObstruction ()+admitBits budget refusal sourceSpan = either (Left . refusal) (const (Right ())) (admitSpan budget sourceSpan)++certifiedContour :: Contour -> Either TopologyObstruction CertifiedContour+certifiedContour (Contour ref pieces)+  | winding == expected = Right (CertifiedContour ref chord (map pieceHull (toList pieces)))+  | otherwise = Left (ContourWindingRefused ref winding)+ where+  chord = (\(Piece _ sourceSpan) -> sourceSpanStart sourceSpan) <$> pieces+  winding = cycleWinding chord+  expected = case ref of+    ContourRef _ OuterContour -> GT+    ContourRef _ (HoleContour _) -> LT+  pieceHull (Piece _ sourceSpan) =+    let hull = sourceSpanControls sourceSpan in PieceHull (exactPointsBounds hull) hull++contourSpan :: ContourRef -> SourceSpan -> ContourSpan+contourSpan ref sourceSpan =+  ContourSpan ref (sourceStepIndex (sourceSpanStep sourceSpan)) (sourceSpanFrom sourceSpan) (sourceSpanTo sourceSpan)++placedKey :: Placed -> (Int, Int)+placedKey (Placed contour position _ _ _) = (contour, position)++placedContour :: Placed -> Int+placedContour (Placed contour _ _ _ _) = contour++placedSpan :: Placed -> ContourSpan+placedSpan (Placed _ _ _ ref (Piece _ sourceSpan)) = contourSpan ref sourceSpan++placedStart :: Placed -> ExactPoint+placedStart (Placed _ _ _ _ (Piece _ sourceSpan)) = sourceSpanStart sourceSpan++placedStep :: Placed -> CurveStep+placedStep (Placed _ _ _ _ (Piece _ sourceSpan)) = sourceSpanPiece sourceSpan++placedBounds :: Placed -> ExactBounds+placedBounds (Placed _ _ _ _ (Piece _ sourceSpan)) = exactPointsBounds (sourceSpanControls sourceSpan)

@@ -0,0 +1,56 @@+-- | The finite budget of an exact subdivision, admitted once, and the+-- obligation a subdivision reports when it spends it. Arc measurement,+-- proximity and topology certification share the one budget and its+-- refusals; what each does beyond subdivision stays with its own owner.+module Moonlight.Planar.Internal.CurveBudget+  ( SubdivisionBudget+  , SubdivisionBudgetError (..)+  , subdivisionBudget+  , budgetDepth+  , budgetLeaves+  , budgetBits+  , BudgetObligation (..)+  ) where++import Control.DeepSeq (NFData (..))++-- | Subdivision depth below any source step, the number of leaves in all,+-- and the largest admitted bit width of any retained exact value.+data SubdivisionBudget = SubdivisionBudget !Int !Int !Int+  deriving stock (Eq, Show)++instance NFData SubdivisionBudget where+  rnf (SubdivisionBudget depth leaves bits) = rnf depth `seq` rnf leaves `seq` rnf bits++data SubdivisionBudgetError+  = InvalidBudgetDepth !Int+  | InvalidBudgetLeaves !Int+  | InvalidBudgetBits !Int+  deriving stock (Eq, Show)++subdivisionBudget :: Int -> Int -> Int -> Either SubdivisionBudgetError SubdivisionBudget+subdivisionBudget depth leaves bits+  | depth < 0 = Left (InvalidBudgetDepth depth)+  | leaves <= 0 = Left (InvalidBudgetLeaves leaves)+  | bits <= 0 = Left (InvalidBudgetBits bits)+  | otherwise = Right (SubdivisionBudget depth leaves bits)++budgetDepth :: SubdivisionBudget -> Int+budgetDepth (SubdivisionBudget depth _ _) = depth++budgetLeaves :: SubdivisionBudget -> Int+budgetLeaves (SubdivisionBudget _ leaves _) = leaves++budgetBits :: SubdivisionBudget -> Int+budgetBits (SubdivisionBudget _ _ bits) = bits++-- | The budget a subdivision could not stay within. A bit refusal carries the+-- offending width; it is raised before the value is compared or retained.+data BudgetObligation+  = LeavesExhausted+  | DepthExhausted+  | BitsExhausted !Int+  deriving stock (Eq, Show)++instance NFData BudgetObligation where+  rnf obligation = obligation `seq` ()

@@ -0,0 +1,240 @@+-- | Exact rational certificates about located curve pieces, taking no square+-- root. Every witness returned is checked by the inequality that defines it,+-- so a returned witness is a proof; 'Nothing' means only that the stated+-- finite candidate search found none, which is complete where said so.+--+-- A piece of any of the four shapes lies in the convex hull of its controls,+-- and its tangent lies in the cone of its nonzero control-polygon edges: a+-- polynomial derivative is a positive Bernstein combination of those edges,+-- and a positive-weight rational quadratic's is a positive combination of+-- @P1 - P0@, @P2 - P0@ and @P2 - P1@, where @P2 - P0@ is the sum of the other+-- two.+--+-- Completeness of 'halfPlaneWitness'. When the nonzero inputs lie in an open+-- half-plane, the two extreme rays of their cone are inputs @a@ and @b@, and+-- @perpendicular (a - b)@, the normal of the segment between their tips, is+-- equally positive at both tips and so, being linear, on the whole cone. When+-- every input is parallel, one of them is itself a witness.+--+-- Exactness of 'crossingVerdict'. When each piece's edge cone meets the+-- other's and its negation only at zero, the chord between two common points+-- would be a nonzero vector in both, so the pieces, and every straight-line+-- homotopy of them to their chords, meet at most once and transversally.+-- With each endpoint strictly outside the other's control hull, which holds+-- that piece and its chord, no endpoint meets the other along the homotopy,+-- so the parity of the meeting count, and with at most one meeting the count+-- itself, is the chords'.+module Moonlight.Planar.Internal.CurveCertificate+  ( halfPlaneWitness+  , separatingAxis+  , hullGap+  , stationaryPiece+  , monotoneWitness+  , jointWitness+  , hullSeparation+  , CrossingCertificate+  , CrossingVerdict (..)+  , crossingVerdict+  ) where++import Control.DeepSeq (NFData (..))+import Data.Foldable (find, toList)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (mapMaybe)+import Moonlight.Planar.Curve (CurveStep, curveStepEnd, stepControlPoints)+import Moonlight.Planar.Exact+  ( ExactPoint, ExactRational, ExactVector (..), exactOrient2d, exactPointCoordinates+  , exactRationalBitWidth, exactVectorFromPoints, translateExactPoint )+import Moonlight.Planar.Internal.CurveBudget (BudgetObligation (..), SubdivisionBudget, budgetBits)+import Moonlight.Planar.Internal.ExactRational (divideByPositive, positiveExact)++-- | A direction strictly positive against every nonzero vector, when the+-- nonzero vectors lie in an open half-plane through the origin. Zero vectors+-- constrain nothing and are dropped; with none left no direction is+-- witnessed.+halfPlaneWitness :: [ExactVector] -> Maybe ExactVector+halfPlaneWitness vectors = find positiveOnAll candidates+ where+  nonzero = filter (/= ExactVector 0 0) vectors+  candidates = nonzero <> [perpendicular (subtractVector a b) | a <- nonzero, b <- nonzero, a /= b]+  positiveOnAll direction = not (null nonzero) && all ((> 0) . dot direction) nonzero++-- | A direction along which every point of the first set lies strictly below+-- every point of the second, so their convex hulls are disjoint. The+-- candidates are complete for possibly degenerate hulls: the closest pair of+-- two disjoint hulls is vertex to vertex, separated along their difference,+-- or vertex to edge, separated along the edge's normal.+separatingAxis :: NonEmpty ExactPoint -> NonEmpty ExactPoint -> Maybe ExactVector+separatingAxis lower upper = find ((> 0) . axisGap lower upper) (axisCandidates lower upper)++-- | The displacement between two point sets' convex hulls, whose square is+-- exactly their squared distance: the zero vector when the hulls meet.+--+-- It is the longest of @(g / |a|^2) a@ over the candidate axes @a@ of+-- 'separatingAxis' with positive gap @g@, how far the second set's least+-- projection on @a@ exceeds the first's greatest; its length is @g / |a|@.+-- Every such length is at most the distance, since projection onto a unit+-- axis lengthens no displacement between the hulls. And one attains it: some+-- closest pair @p@, @q@ of disjoint hulls is vertex to vertex or vertex to a+-- point inside an edge, so @q - p@ is a between-set difference or a normal of+-- a within-set difference, a candidate with either sign; the lines through+-- @p@ and @q@ normal to @q - p@ support the two hulls, so along it @g / |a|@+-- is @|q - p|@. When the hulls meet no candidate has a positive gap. The+-- square is rational; the distance itself is not taken.+hullGap :: NonEmpty ExactPoint -> NonEmpty ExactPoint -> ExactVector+hullGap lower upper = foldr longer (ExactVector 0 0) (mapMaybe along (axisCandidates lower upper))+ where+  along axis = case (axisGap lower upper axis, positiveExact (dot axis axis)) of+    (gap, Right norm) | gap > 0 -> Just (scaleVector (divideByPositive gap norm) axis)+    _ -> Nothing+  longer candidate best+    | dot candidate candidate > dot best best = candidate+    | otherwise = best++-- The differences within each set, turned a quarter, and the differences+-- between the sets, each with both signs.+axisCandidates :: NonEmpty ExactPoint -> NonEmpty ExactPoint -> [ExactVector]+axisCandidates lower upper = concatMap (\axis -> [axis, negateVector axis]) axes+ where+  lows = toList lower+  highs = toList upper+  differences points = [exactVectorFromPoints p q | p <- points, q <- points, p /= q]+  axes = map perpendicular (differences lows <> differences highs)+    <> [exactVectorFromPoints p q | p <- lows, q <- highs, p /= q]++-- How far the second set's least projection on the axis exceeds the first's+-- greatest.+axisGap :: NonEmpty ExactPoint -> NonEmpty ExactPoint -> ExactVector -> ExactRational+axisGap lower upper axis = minimum1 (project axis <$> upper) - maximum1 (project axis <$> lower)+ where+  minimum1, maximum1 :: NonEmpty ExactRational -> ExactRational+  minimum1 (x :| xs) = foldr min x xs+  maximum1 (x :| xs) = foldr max x xs++-- | Whether every control of the piece is its start, so it never moves.+stationaryPiece :: CurveStep -> Bool+stationaryPiece = all (== ExactVector 0 0) . controlEdges++-- | A direction along which the piece strictly advances, so the piece is+-- injective and so is its straight-line homotopy to its chord. A stationary+-- piece has no witness.+monotoneWitness :: CurveStep -> Maybe ExactVector+monotoneWitness = halfPlaneWitness . controlEdges++-- | A direction separating two consecutive pieces at their joint @V@: the+-- incoming piece's controls lie strictly ahead of @V@ along it, apart from+-- @V@ itself, and the outgoing piece's strictly behind, so the two meet only+-- at @V@. A cusp, whose tangent reverses, has none. Stationary pieces are+-- contracted by the caller before their joints are tested.+jointWitness :: CurveStep -> CurveStep -> Maybe ExactVector+jointWitness incoming outgoing =+  halfPlaneWitness (fromJoint <> map negateVector (toList (stepControlPoints outgoing)))+ where+  fromJoint = map (`subtractVector` curveStepEnd incoming) (toList (stepControlPoints incoming))++-- | A direction strictly separating two located pieces' control hulls, so the+-- pieces are disjoint.+hullSeparation :: ExactPoint -> CurveStep -> ExactPoint -> CurveStep -> Maybe ExactVector+hullSeparation startA stepA startB stepB = separatingAxis (controls startA stepA) (controls startB stepB)++-- | Why two pieces meet at most once and transversally, and why their chords+-- decide whether they do: a direction positive on both pieces' edges, one+-- positive on the first's and negative on the second's, and an axis+-- separating each endpoint from the other piece's control hull. It carries no+-- crossing point, which is algebraic in general.+data CrossingCertificate = CrossingCertificate+  !ExactVector !ExactVector !ExactVector !ExactVector !ExactVector !ExactVector+  deriving stock (Eq, Show)++-- The widest coordinate a certificate carries.+certificateBits :: CrossingCertificate -> Int+certificateBits (CrossingCertificate same opposite a0 a1 b0 b1) =+  maximum1 (vectorWidth <$> same :| [opposite, a0, a1, b0, b1])+ where+  vectorWidth (ExactVector x y) = max (exactRationalBitWidth x) (exactRationalBitWidth y)+  maximum1 :: NonEmpty Int -> Int+  maximum1 (x :| xs) = foldr max x xs++instance NFData CrossingCertificate where+  rnf (CrossingCertificate same opposite a0 a1 b0 b1) =+    rnf same `seq` rnf opposite `seq` rnf a0 `seq` rnf a1 `seq` rnf b0 `seq` rnf b1++-- | The pieces cross exactly once, transversally, or not at all.+data CrossingVerdict+  = SingleCrossing !CrossingCertificate+  | NoCrossing !CrossingCertificate+  deriving stock (Eq, Show)++instance NFData CrossingVerdict where+  rnf (SingleCrossing certificate) = rnf certificate+  rnf (NoCrossing certificate) = rnf certificate++verdictCertificate :: CrossingVerdict -> CrossingCertificate+verdictCertificate (SingleCrossing certificate) = certificate+verdictCertificate (NoCrossing certificate) = certificate++-- | The exact crossing verdict for two located pieces, when their cones and+-- endpoints admit one. The chords cross exactly when each chord's endpoints+-- lie strictly on opposite sides of the other's line; no endpoint can lie on+-- the other chord, which is inside that piece's control hull. A verdict is+-- returned only with its certificate admitted under the budget's bits, so+-- every caller that retains one retains an admitted one; a wider certificate+-- refuses with its width.+crossingVerdict+  :: SubdivisionBudget -> ExactPoint -> CurveStep -> ExactPoint -> CurveStep+  -> Either BudgetObligation (Maybe CrossingVerdict)+crossingVerdict budget startA stepA startB stepB =+  traverse admitted+    ( verdict+        <$> halfPlaneWitness (edgesA <> edgesB)+        <*> halfPlaneWitness (edgesA <> map negateVector edgesB)+        <*> outside a0 hullB <*> outside a1 hullB <*> outside b0 hullA <*> outside b1 hullA )+ where+  admitted found+    | width > budgetBits budget = Left (BitsExhausted width)+    | otherwise = Right found+   where+    width = certificateBits (verdictCertificate found)+  edgesA = controlEdges stepA+  edgesB = controlEdges stepB+  hullA = controls startA stepA+  hullB = controls startB stepB+  a0 = startA+  a1 = translateExactPoint startA (curveStepEnd stepA)+  b0 = startB+  b1 = translateExactPoint startB (curveStepEnd stepB)+  outside point hull = separatingAxis (point :| []) hull+  chordsCross = opposite (exactOrient2d a0 a1 b0) (exactOrient2d a0 a1 b1)+    && opposite (exactOrient2d b0 b1 a0) (exactOrient2d b0 b1 a1)+  opposite left right = (left, right) `elem` [(LT, GT), (GT, LT)]+  verdict same opposed axisA0 axisA1 axisB0 axisB1+    | chordsCross = SingleCrossing certificate+    | otherwise = NoCrossing certificate+   where+    certificate = CrossingCertificate same opposed axisA0 axisA1 axisB0 axisB1++controls :: ExactPoint -> CurveStep -> NonEmpty ExactPoint+controls start step = translateExactPoint start <$> stepControlPoints step++controlEdges :: CurveStep -> [ExactVector]+controlEdges step = zipWith (flip subtractVector) points (drop 1 points)+ where+  points = toList (stepControlPoints step)++project :: ExactVector -> ExactPoint -> ExactRational+project (ExactVector ax ay) point = let (x, y) = exactPointCoordinates point in ax * x + ay * y++dot :: ExactVector -> ExactVector -> ExactRational+dot (ExactVector ax ay) (ExactVector bx by) = ax * bx + ay * by++perpendicular :: ExactVector -> ExactVector+perpendicular (ExactVector x y) = ExactVector (negate y) x++subtractVector :: ExactVector -> ExactVector -> ExactVector+subtractVector (ExactVector ax ay) (ExactVector bx by) = ExactVector (ax - bx) (ay - by)++scaleVector :: ExactRational -> ExactVector -> ExactVector+scaleVector factor (ExactVector x y) = ExactVector (factor * x) (factor * y)++negateVector :: ExactVector -> ExactVector+negateVector (ExactVector x y) = ExactVector (negate x) (negate y)

@@ -0,0 +1,246 @@+-- | Source-span provenance and selection for canonical curves: the one owner+-- of which step of a source a span refines and where a site on it lies.+--+-- It owns three invariants. A 'SourceStep' is built only by 'sourceSteps',+-- from the source's own 'trailSteps', or 'closedTrailSteps' for a closed+-- trail, so its index and count are valid for its source by construction and+-- its located start is the anchor translated by the steps before it. A closed+-- trail's seam is a join: the closing step's end and the first step's start+-- are one point. A 'TrailSite' is built only by 'trailSite', which decides its+-- 'JoinSide' from the step's index and count and the source's closure.+--+-- A site's point is its step's exact point at its parameter: the step's+-- located start translated by 'evaluateStep'. 'trailSite' takes the point as+-- given, so that obligation rests with its callers inside the package:+-- 'selectSite' evaluates the step; measurement and proximity carry the point+-- of their exact subdivision, which agrees with evaluation; and proximity's+-- nearest point on a straight piece is the step's own affine point at the+-- parameter.+module Moonlight.Planar.Internal.CurveSource+  ( SourceStep+  , sourceSteps+  , sourceStepIndex+  , sourceStepCount+  , sourceStepStart+  , sourceStepCurve+  , JoinSide (..)+  , TrailSite+  , trailSite+  , siteSource+  , siteStep+  , siteStepIndex+  , siteParameter+  , sitePoint+  , siteJoinSide+  , siteJet+  , selectSite+  , joinNeighbourJet+  , SourceSpan+  , wholeSpan+  , halveSpan+  , sourceSpanStep+  , sourceSpanFrom+  , sourceSpanTo+  , sourceSpanStart+  , sourceSpanPiece+  , sourceSpanControls+  , admitSpan+  , spanBits+  ) where++import Control.DeepSeq (NFData (..))+import Data.List.NonEmpty (NonEmpty)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Moonlight.Planar.Curve+  ( CurveShapeView (..), CurveStep, StepJet, Subpath (..), closedTrailSteps, curveStepEnd+  , curveStepShape, evaluateStep, jetStep, location, locatedValue, shapeView, splitStep+  , stepControlPoints, trailSteps )+import Moonlight.Planar.Exact+  ( ExactPoint, ExactVector (..), UnitInterval, exactPointBitWidth, exactRationalBitWidth+  , positiveExactValue, translateExactPoint, unitHalf, unitIntervalValue, unitOne, unitZero )+import Moonlight.Planar.Internal.CurveBudget (BudgetObligation (..), SubdivisionBudget, budgetBits)+import Moonlight.Planar.Internal.ExactRational (unitMidpoint)++-- | One step of a source as the source itself has it: its index among the+-- source's actual steps, their count, its located start, and the step. Only+-- 'sourceSteps' builds one, so an index is valid for its source by+-- construction.+data SourceStep = SourceStep !Int !Int !ExactPoint !CurveStep+  deriving stock (Eq, Show)++instance NFData SourceStep where+  rnf (SourceStep index count start step) =+    rnf index `seq` rnf count `seq` rnf start `seq` rnf step++sourceStepIndex :: SourceStep -> Int+sourceStepIndex (SourceStep index _ _ _) = index++sourceStepCount :: SourceStep -> Int+sourceStepCount (SourceStep _ count _ _) = count++-- | The located start of the step.+sourceStepStart :: SourceStep -> ExactPoint+sourceStepStart (SourceStep _ _ start _) = start++sourceStepCurve :: SourceStep -> CurveStep+sourceStepCurve (SourceStep _ _ _ step) = step++-- | Which side of a join a site lies on. The end of one step and the start of+-- the next are one point; a site there is on exactly one of the two steps, at+-- parameter one before the join or at parameter zero after it. A site inside+-- a step, or at an open trail's own start or end, is away from any join; a+-- closed trail's seam is a join.+data JoinSide+  = AwayFromJoin+  | BeforeJoin+  | AfterJoin+  deriving stock (Eq, Ord, Show)++instance NFData JoinSide where+  rnf side = side `seq` ()++-- | A located position on one selected step of its source. Only 'trailSite'+-- builds one; the point is the step's exact point at the parameter.+data TrailSite = TrailSite !Subpath !SourceStep !UnitInterval !ExactPoint !JoinSide+  deriving stock (Eq, Show)++instance NFData TrailSite where+  rnf (TrailSite source step parameter point side) =+    rnf source `seq` rnf step `seq` rnf parameter `seq` rnf point `seq` rnf side++siteSource :: TrailSite -> Subpath+siteSource (TrailSite source _ _ _ _) = source++siteStep :: TrailSite -> SourceStep+siteStep (TrailSite _ step _ _ _) = step++siteStepIndex :: TrailSite -> Int+siteStepIndex = sourceStepIndex . siteStep++siteParameter :: TrailSite -> UnitInterval+siteParameter (TrailSite _ _ parameter _ _) = parameter++sitePoint :: TrailSite -> ExactPoint+sitePoint (TrailSite _ _ _ point _) = point++siteJoinSide :: TrailSite -> JoinSide+siteJoinSide (TrailSite _ _ _ _ side) = side++-- | The site's value and derivatives on its own step, relative to the step's+-- located start.+siteJet :: TrailSite -> StepJet+siteJet site = jetStep (siteParameter site) (sourceStepCurve (siteStep site))++-- | The source's steps with their indices and located starts: the one owner+-- of step selection.+sourceSteps :: Subpath -> Seq SourceStep+sourceSteps source =+  Seq.mapWithIndex (\index (start, step) -> SourceStep index count start step) (Seq.zip starts steps)+ where+  (anchor, steps) = case source of+    OpenSubpath value -> (location value, trailSteps (locatedValue value))+    ClosedSubpath value -> (location value, closedTrailSteps (locatedValue value))+  count = Seq.length steps+  starts = Seq.scanl (\start step -> translateExactPoint start (curveStepEnd step)) anchor steps++trailSite :: Subpath -> SourceStep -> UnitInterval -> ExactPoint -> TrailSite+trailSite source step@(SourceStep index count _ _) parameter point =+  TrailSite source step parameter point side+ where+  closed = case source of+    ClosedSubpath _ -> True+    OpenSubpath _ -> False+  side+    | parameter == unitOne && (closed || index + 1 < count) = BeforeJoin+    | parameter == unitZero && (closed || index > 0) = AfterJoin+    | otherwise = AwayFromJoin++-- | The site at a parameter of the source's step at an index, if the source+-- has that step.+selectSite :: Subpath -> Int -> UnitInterval -> Maybe TrailSite+selectSite source index parameter = place <$> Seq.lookup index (sourceSteps source)+ where+  place step = trailSite source step parameter+    (translateExactPoint (sourceStepStart step) (evaluateStep parameter (sourceStepCurve step)))++-- | The jet of the other step at a site's join: the next step's start before+-- the join, the previous step's end after it. Only a closed trail's seam+-- joins its last and first steps, and 'trailSite' marks an open trail's own+-- start and end away from any join, so the neighbour index is reduced modulo+-- the count, which the site's step makes positive.+joinNeighbourJet :: TrailSite -> Maybe StepJet+joinNeighbourJet (TrailSite source (SourceStep index count _ _) _ _ side) = case side of+  AwayFromJoin -> Nothing+  BeforeJoin -> neighbour (index + 1) unitZero+  AfterJoin -> neighbour (index - 1) unitOne+ where+  neighbour at parameter =+    jetStep parameter . sourceStepCurve <$> Seq.lookup (at `mod` count) (sourceSteps source)++-- | One span of a source step as subdivision reaches it: the step, a bracket+-- of its parameters, the span's located start, and the piece. Only+-- 'wholeSpan' and 'halveSpan' build one, so the piece is the step restricted+-- to the bracket and the start is the step's point at the bracket's lower+-- parameter.+data SourceSpan = SourceSpan !SourceStep !UnitInterval !UnitInterval !ExactPoint !CurveStep+  deriving stock (Eq, Show)++instance NFData SourceSpan where+  rnf (SourceSpan step from to start piece) =+    rnf step `seq` rnf from `seq` rnf to `seq` rnf start `seq` rnf piece++wholeSpan :: SourceStep -> SourceSpan+wholeSpan step = SourceSpan step unitZero unitOne (sourceStepStart step) (sourceStepCurve step)++-- | The span's two halves: exact de Casteljau subdivision at the piece's own+-- midpoint, which is the bracket's midpoint in the step's parameter.+halveSpan :: SourceSpan -> (SourceSpan, SourceSpan)+halveSpan (SourceSpan step from to start piece) =+  ( SourceSpan step from middle start left+  , SourceSpan step middle to (translateExactPoint start (curveStepEnd left)) right )+ where+  (left, right) = splitStep unitHalf piece+  middle = unitMidpoint from to++sourceSpanStep :: SourceSpan -> SourceStep+sourceSpanStep (SourceSpan step _ _ _ _) = step++sourceSpanFrom :: SourceSpan -> UnitInterval+sourceSpanFrom (SourceSpan _ from _ _ _) = from++sourceSpanTo :: SourceSpan -> UnitInterval+sourceSpanTo (SourceSpan _ _ to _ _) = to++sourceSpanStart :: SourceSpan -> ExactPoint+sourceSpanStart (SourceSpan _ _ _ start _) = start++sourceSpanPiece :: SourceSpan -> CurveStep+sourceSpanPiece (SourceSpan _ _ _ _ piece) = piece++-- | The piece's controls, located at the span's start: the hull a caller+-- retains, queries and compares.+sourceSpanControls :: SourceSpan -> NonEmpty ExactPoint+sourceSpanControls (SourceSpan _ _ _ start piece) = translateExactPoint start <$> stepControlPoints piece++-- | Admit a span under the budget's bits, the one gate every consumer of a+-- span passes: its located start, parameters, relative controls and weights,+-- and its located controls, whose width the relative ones do not bound.+admitSpan :: SubdivisionBudget -> SourceSpan -> Either BudgetObligation SourceSpan+admitSpan budget sourceSpan@(SourceSpan _ from to start piece)+  | width > budgetBits budget = Left (BitsExhausted width)+  | otherwise = Right sourceSpan+ where+  width = foldr (max . exactPointBitWidth) (spanBits start from to piece) (sourceSpanControls sourceSpan)++-- | The widest of a span's located start, parameters, controls and rational+-- weights.+spanBits :: ExactPoint -> UnitInterval -> UnitInterval -> CurveStep -> Int+spanBits from t0 t1 step =+  foldr (max . exactRationalBitWidth) (exactPointBitWidth from)+    (unitIntervalValue t0 : unitIntervalValue t1 : weights <> controls)+ where+  controls = concatMap (\(ExactVector x y) -> [x, y]) (stepControlPoints step)+  weights = case shapeView (curveStepShape step) of+    RationalQuadraticView _ a b -> [positiveExactValue a, positiveExactValue b]+    _ -> []

@@ -0,0 +1,424 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++-- | Certified Euclidean length arithmetic, independent of geometry: finite+-- sums of rational multiples of square roots in radical normal form, their+-- outward rational enclosures at an admitted precision, and the directed+-- binary64 projection of those enclosures. Region valuation and curve+-- measurement share this one owner.+module Moonlight.Planar.Internal.Length+  ( ExactLengthTerm+  , lengthCoefficient+  , lengthRadicand+  , ExactLengthExpression+  , exactLengthTerms+  , normalizeLengthContributions+  , scaleLengthExpression+  , RadicalPrecision+  , RadicalPrecisionError (..)+  , radicalPrecision+  , radicalPrecisionBits+  , publicationPrecision+  , LengthEnclosure+  , lengthEnclosureLower+  , lengthEnclosureUpper+  , lengthEnclosureWidth+  , enclosureBetween+  , LengthError (..)+  , squareRootEnclosure+  , expressionEnclosure+  , euclideanLengthEnclosure+  , CertifiedInterval (..)+  , certifiedInterval+  , ExactLengthMeasurement+  , exactLengthExpression+  , exactLengthBounds+  , measureLengthExpression+  ) where++import Control.DeepSeq (NFData)+import Data.Bits (shiftL)+import Data.Foldable (foldlM)+import qualified Data.IntSet as IntSet+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Ratio as Ratio+import Data.Word (Word64)+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+import GHC.Generics (Generic)+import Moonlight.Planar.Internal.Dyadic (integerBitLength)+import Moonlight.Planar.Internal.ExactRational+  ( ExactRational+  , exactRationalDenominator+  , exactRationalFromDyadic+  , exactRationalFromFiniteDouble+  , exactRationalFromNormalizedRatio+  , exactRationalNumerator+  , exactSignum+  , PositiveExact+  , positiveExactValue+  , positiveOne+  )++data ExactLengthTerm = ExactLengthTerm+  { lengthCoefficient :: !ExactRational+  , lengthRadicand :: !Integer+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A normalized sum of rational coefficients times square roots of integer+-- radicands. No two radicands differ by a rational square, so equal lengths+-- are one term and rational length is the radicand-1 term; each radicand is+-- reduced by the square factors of the primes below 64 and by a perfect-square+-- cofactor. A squared prime above that bound inside a non-square cofactor is+-- beyond factoring-free reach, so the presentation is canonical within an+-- expression and across expressions only up to such factors; there is no+-- 'Eq' instance for that reason.+newtype ExactLengthExpression = ExactLengthExpression [ExactLengthTerm]+  deriving stock (Show, Generic)+  deriving anyclass (NFData)++exactLengthTerms :: ExactLengthExpression -> [ExactLengthTerm]+exactLengthTerms (ExactLengthExpression terms) = terms++-- | Binary64 endpoints rounded outward from a rational enclosure.+data CertifiedInterval = CertifiedInterval+  { intervalLower :: !Double+  , intervalUpper :: !Double+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data ExactLengthMeasurement = ExactLengthMeasurement+  { exactLengthExpression :: !ExactLengthExpression+  , exactLengthBounds :: !CertifiedInterval+  }+  deriving stock (Show, Generic)+  deriving anyclass (NFData)++-- | Fractional bits of a square-root enclosure: each root is bracketed by+-- consecutive multiples of @2^-bits@, so its width is at most @2^-bits@.+newtype RadicalPrecision = RadicalPrecision Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A root is bracketed by shifting its radicand left by twice the precision,+-- so the doubled count must itself be a representable shift.+data RadicalPrecisionError+  = NonPositiveRadicalPrecision !Int+  | UnrepresentableRadicalPrecision !Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++radicalPrecision :: Int -> Either RadicalPrecisionError RadicalPrecision+radicalPrecision bits+  | bits <= 0 = Left (NonPositiveRadicalPrecision bits)+  | bits > maxBound `quot` 2 = Left (UnrepresentableRadicalPrecision bits)+  | otherwise = Right (RadicalPrecision bits)++radicalPrecisionBits :: RadicalPrecision -> Int+radicalPrecisionBits (RadicalPrecision bits) = bits++-- | 128 bits: far below binary64 resolution for any length a double can+-- represent, so directed publication, not the rational enclosure, dominates+-- the width of a 'CertifiedInterval'.+publicationPrecision :: RadicalPrecision+publicationPrecision = RadicalPrecision 128++-- | An ordered pair of nonnegative rationals, @0 <= lower <= upper@. The sum+-- of enclosures encloses the sum of their values.+data LengthEnclosure = LengthEnclosure !ExactRational !ExactRational+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++instance Semigroup LengthEnclosure where+  LengthEnclosure a b <> LengthEnclosure c d = LengthEnclosure (a + c) (b + d)++instance Monoid LengthEnclosure where+  mempty = LengthEnclosure 0 0++lengthEnclosureLower :: LengthEnclosure -> ExactRational+lengthEnclosureLower (LengthEnclosure lower _) = lower++lengthEnclosureUpper :: LengthEnclosure -> ExactRational+lengthEnclosureUpper (LengthEnclosure _ upper) = upper++lengthEnclosureWidth :: LengthEnclosure -> ExactRational+lengthEnclosureWidth (LengthEnclosure lower upper) = upper - lower++-- | The first's lower bound to the second's upper bound: it encloses every+-- value lying between the first's value and the second's whenever the first+-- is at most the second, as a chord is at most its control polygon. The+-- endpoints are ordered for any pair.+enclosureBetween :: LengthEnclosure -> LengthEnclosure -> LengthEnclosure+enclosureBetween (LengthEnclosure a _) (LengthEnclosure _ d) = LengthEnclosure (min a d) (max a d)++-- | A negative square has no real root.+newtype LengthError = LengthNegativeSquare ExactRational+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Positive coefficients stay positive through merging, whose scales are+-- positive integers, so every normalized term has a positive coefficient.+-- This and 'scaleLengthExpression' are the only expression builders, which is+-- the invariant 'expressionEnclosure' relies on.+normalizeLengthContributions+  :: Foldable collection+  => (value -> (PositiveExact, ExactRational))+  -> collection value+  -> ExactLengthExpression+normalizeLengthContributions contribution =+  normalizeSquareCoefficients . List.foldl' accumulateContribution Map.empty+ where+  accumulateContribution coefficients value =+    let (coefficient, square) = contribution value+     in Map.insertWith (+) square (positiveExactValue coefficient) coefficients+-- Only the per-contribution fold is inlined, so each caller's contribution+-- fuses into it and no pair is built per element; the class merging below is+-- shared out of line.+{-# INLINE normalizeLengthContributions #-}++-- | Merge per-square coefficients into radical classes.+normalizeSquareCoefficients :: Map.Map ExactRational ExactRational -> ExactLengthExpression+normalizeSquareCoefficients coefficientsBySquare =+  ExactLengthExpression+    [ ExactLengthTerm coefficient radicand+    | (radicand, coefficient) <- List.sortOn fst (concat (Map.elems classes))+    ]+ where+  classes =+    Map.foldlWithKey' accumulateRadical Map.empty coefficientsBySquare+  accumulateRadical buckets square coefficient =+    let reduced = reduceRadicand square+     in if radicalRadicand reduced == 0+          then buckets+          else+            Map.alter+              ( Just+                  . mergeRadical (coefficient * radicalScale reduced) (radicalRadicand reduced)+                  . fromMaybe []+              )+              (radicalClassKey reduced)+              buckets++data ReducedRadical = ReducedRadical+  { radicalScale :: !ExactRational+  , radicalRadicand :: !Integer+  , radicalClassKey :: !Word64+  }++-- | Write √(n/d) as (1/d)·√(n·d), fold the even part of each trial prime's+-- multiplicity and a perfect-square cofactor into the scale, and key the+-- radicand by what those primes observe of its square class: the parity of+-- the multiplicity and the quadratic character of the prime-free part, both+-- invariant under multiplication by rational squares.+reduceRadicand :: ExactRational -> ReducedRadical+reduceRadicand square+  | radicand <= 0 = ReducedRadical inverseDenominator radicand 0+  | otherwise =+      let (cofactor, reduced) = List.foldl' stripPrime (radicand, initial) radicalPrimes+          root = integerSquareRoot cofactor+       in if root * root == cofactor+            then reduced {radicalScale = radicalScale reduced * fromInteger root}+            else reduced {radicalRadicand = radicalRadicand reduced * cofactor}+ where+  denominator = exactRationalDenominator square+  radicand = exactRationalNumerator square * denominator+  inverseDenominator = exactRationalFromNormalizedRatio (1 Ratio.% denominator)+  initial = ReducedRadical inverseDenominator 1 0+  stripPrime (remaining, reduced) (prime, residues) =+    let (multiplicity, rest) = primeMultiplicity prime remaining+        (halfPower, parity) = multiplicity `divMod` 2+        character = squareClassCharacter prime residues rest+     in ( rest+        , ReducedRadical+            { radicalScale = radicalScale reduced * fromInteger (prime ^ halfPower)+            , radicalRadicand = radicalRadicand reduced * prime ^ parity+            , radicalClassKey = radicalClassKey reduced * 8 + fromIntegral (parity * 4 + character)+            }+        )++radicalPrimes :: [(Integer, IntSet.IntSet)]+radicalPrimes =+  [ (toInteger prime, IntSet.fromList [(x * x) `mod` prime | x <- [1 .. prime - 1]])+  | prime <- [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61 :: Int]+  ]++primeMultiplicity :: Integer -> Integer -> (Int, Integer)+primeMultiplicity prime = go 0+ where+  go :: Int -> Integer -> (Int, Integer)+  go !count value =+    case value `quotRem` prime of+      (quotient, 0) -> go (count + 1) quotient+      _ -> (count, value)++squareClassCharacter :: Integer -> IntSet.IntSet -> Integer -> Int+squareClassCharacter 2 _ rest = fromInteger ((rest `mod` 8) `div` 2)+squareClassCharacter prime residues rest =+  if IntSet.member (fromInteger (rest `mod` prime)) residues then 1 else 0++-- | Fold a term into its square class: the product of two radicands of one+-- class is a perfect square, whose root exposes the rational square relating+-- them, so both fold onto their common divisor with integer scales.+mergeRadical+  :: ExactRational+  -> Integer+  -> [(Integer, ExactRational)]+  -> [(Integer, ExactRational)]+mergeRadical coefficient radicand = go+ where+  go [] = [(radicand, coefficient)]+  go ((kernel, total) : rest)+    | pairRoot * pairRoot == pairProduct =+        let common = gcd pairRoot kernel+            newScale = pairRoot `div` common+            oldScale = kernel `div` common+         in ( kernel `div` (oldScale * oldScale)+            , total * fromInteger oldScale + coefficient * fromInteger newScale+            )+              : rest+    | otherwise = (kernel, total) : go rest+   where+    pairProduct = radicand * kernel+    pairRoot = integerSquareRoot pairProduct++scaleLengthExpression+  :: PositiveExact+  -> ExactLengthExpression+  -> ExactLengthExpression+scaleLengthExpression scalar (ExactLengthExpression terms) =+  let exactScalar = positiveExactValue scalar+   in ExactLengthExpression+        [ term+            { lengthCoefficient =+                exactScalar * lengthCoefficient term+            }+        | term <- terms+        ]++-- | The root of a nonnegative rational between consecutive multiples of+-- @2^-bits@; an exact dyadic root has zero width.+squareRootEnclosure+  :: RadicalPrecision+  -> ExactRational+  -> Either LengthError LengthEnclosure+squareRootEnclosure (RadicalPrecision bits) value =+  case exactSignum value of+    LT -> Left (LengthNegativeSquare value)+    _ -> Right (uncurry LengthEnclosure (rootBounds bits value))++-- | Consecutive multiples of @2^-bits@ around the root of a nonnegative value.+rootBounds :: Int -> ExactRational -> (ExactRational, ExactRational)+rootBounds bits value =+  let numerator = exactRationalNumerator value+      denominator = exactRationalDenominator value+      scaledNumerator = numerator `shiftL` (2 * bits)+      root = integerSquareRoot (scaledNumerator `div` denominator)+      exact = root * root * denominator == scaledNumerator+      dyadicPower = negate bits+   in ( exactRationalFromDyadic root dyadicPower+      , exactRationalFromDyadic (if exact then root else root + 1) dyadicPower+      )++-- | Outward enclosure of the expression's value. Coefficients are positive by+-- construction, so each term scales its root enclosure without reordering; a+-- negative radicand, from a negative squared length, is refused.+expressionEnclosure+  :: RadicalPrecision+  -> ExactLengthExpression+  -> Either LengthError LengthEnclosure+expressionEnclosure precision (ExactLengthExpression terms) =+  foldlM addTerm mempty terms+ where+  addTerm (LengthEnclosure lower upper) (ExactLengthTerm coefficient radicand) = do+    LengthEnclosure lowerRoot upperRoot <-+      squareRootEnclosure precision (fromInteger radicand)+    pure (LengthEnclosure (lower + coefficient * lowerRoot) (upper + coefficient * upperRoot))++-- | Outward enclosure of the summed Euclidean norms of rational displacements,+-- through the radical normal form. Every contribution has coefficient one and+-- a nonnegative square, so every normalized term has a positive coefficient+-- and a positive radicand, and the enclosure needs no refusal. Each term's+-- endpoints are rounded outward onto multiples of @2^-bits@, so sums of these+-- enclosures stay on that grid instead of accumulating the coefficients'+-- denominators.+euclideanLengthEnclosure+  :: RadicalPrecision+  -> [(ExactRational, ExactRational)]+  -> LengthEnclosure+euclideanLengthEnclosure (RadicalPrecision bits) displacements =+  foldMap termEnclosure+    (exactLengthTerms (normalizeLengthContributions (\(x, y) -> (positiveOne, x * x + y * y)) displacements))+ where+  termEnclosure (ExactLengthTerm coefficient radicand) =+    let (lower, upper) = rootBounds bits (fromInteger radicand)+     in LengthEnclosure (gridFloor (coefficient * lower)) (negate (gridFloor (negate (coefficient * upper))))+  gridFloor value = exactRationalFromDyadic+    ((exactRationalNumerator value `shiftL` bits) `div` exactRationalDenominator value) (negate bits)++-- | Directed binary64 publication of a rational enclosure.+certifiedInterval :: LengthEnclosure -> CertifiedInterval+certifiedInterval (LengthEnclosure lower upper) =+  CertifiedInterval+    { intervalLower = directedLowerDouble lower+    , intervalUpper = directedUpperDouble upper+    }++measureLengthExpression+  :: RadicalPrecision+  -> ExactLengthExpression+  -> Either LengthError ExactLengthMeasurement+measureLengthExpression precision expression =+  ExactLengthMeasurement expression . certifiedInterval+    <$> expressionEnclosure precision expression++integerSquareRoot :: Integer -> Integer+integerSquareRoot value+  | value < 2 = value+  | otherwise = descend initial+ where+  initial = 1 `shiftL` ((integerBitLength value + 1) `div` 2)+  descend estimate =+    let refined = (estimate + value `div` estimate) `div` 2+     in if refined >= estimate then estimate else descend refined++directedLowerDouble :: ExactRational -> Double+directedLowerDouble value =+  let candidate = rationalToDouble value+   in if isInfinite candidate+        then maximumFiniteDouble+        else+          if exactRationalFromFiniteDouble candidate <= value+            then candidate+            else previousPositiveDouble candidate++directedUpperDouble :: ExactRational -> Double+directedUpperDouble value =+  let candidate = rationalToDouble value+   in if isInfinite candidate+        || exactRationalFromFiniteDouble candidate >= value+        then candidate+        else nextPositiveDouble candidate++rationalToDouble :: ExactRational -> Double+rationalToDouble value =+  fromRational+    ( exactRationalNumerator value+        Ratio.% exactRationalDenominator value+    )++previousPositiveDouble :: Double -> Double+previousPositiveDouble value+  | value <= 0 = 0+  | otherwise = castWord64ToDouble (castDoubleToWord64 value - 1)++nextPositiveDouble :: Double -> Double+nextPositiveDouble value+  | value == 0 = castWord64ToDouble 1+  | otherwise = castWord64ToDouble (castDoubleToWord64 value + 1)++maximumFiniteDouble :: Double+maximumFiniteDouble = castWord64ToDouble 0x7fefffffffffffff

@@ -0,0 +1,157 @@+-- | One admitted loop prepared once for the relation and location questions+-- every region check asks of it, and exact point location in a closed chain+-- of exact points. Region admission and curve-region certification both read+-- these; neither re-derives them.+module Moonlight.Planar.Internal.Region.Loop+  ( LoopRelationWitness (..)+  , PreparedLoop+  , prepareLoop+  , preparedBounds+  , firstPreparedPoint+  , loopSegments+  , crossLoopRelations+  , preparedPointLocation+  , pointLocationInLoop+  , pointLocationInCycle+  , loopWinding+  , cycleWinding+  ) where++import Data.Bifunctor (first)+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import qualified Data.Vector as V+import Moonlight.Planar.Exact+  ( ExactBounds+  , boundsOverlap+  , exactPointsBounds+  , pointInBounds+  , ExactPoint+  , ExactSegment+  , SegmentRelation+  , exactOnClosedSegment+  , exactOrient2d+  , exactPointCoordinates+  , exactPointCross+  , exactSegment+  )+import Moonlight.Planar.Internal.BoundaryCycle (cyclePairs)+import Moonlight.Planar.Internal.ExactRational (exactSignum)+import Moonlight.Planar.Internal.ExactSegmentEvents+  ( ExactSweepSegmentId (..)+  , exactSegmentEventPlan+  , exactSegmentRelationMap+  )+import Moonlight.Planar.Internal.Region.Bounds (exactLoopBounds)+import Moonlight.Planar.Internal.Region.Types+  ( ExactLoop (..)+  , RegionPointLocation (..)+  , RegionValidationError (..)+  )++data LoopRelationWitness = LoopRelationWitness+  !Int+  !Int+  !ExactSegment+  !ExactSegment+  !SegmentRelation++-- | One admitted loop with the bounds and segment vector every relation+-- question reads, built once per loop rather than once per pair asked.+data PreparedLoop = PreparedLoop+  !ExactLoop+  !ExactBounds+  !(V.Vector ExactSegment)++prepareLoop :: ExactLoop -> Either RegionValidationError PreparedLoop+prepareLoop loop@(ExactLoop points) =+  PreparedLoop loop (exactLoopBounds loop) <$> loopSegments points++preparedBounds :: PreparedLoop -> ExactBounds+preparedBounds (PreparedLoop _ bounds _) = bounds++firstPreparedPoint :: PreparedLoop -> ExactPoint+firstPreparedPoint (PreparedLoop (ExactLoop (point :| _)) _ _) = point++loopSegments+  :: NonEmpty ExactPoint+  -> Either RegionValidationError (V.Vector ExactSegment)+loopSegments points =+  V.fromList+    <$> traverse+      (\(from, to) ->+         first (const (RegionLoopDegenerate (NonEmpty.toList points)))+           (exactSegment from to))+      (cyclePairs points)++crossLoopRelations+  :: PreparedLoop+  -> PreparedLoop+  -> Either RegionValidationError [LoopRelationWitness]+crossLoopRelations (PreparedLoop _ leftBounds leftSegments) (PreparedLoop _ rightBounds rightSegments)+  | not (boundsOverlap leftBounds rightBounds) = Right []+  | otherwise = do+      let leftCount = V.length leftSegments+      plan <-+        first RegionSegmentEventsInvalid+          (exactSegmentEventPlan (leftSegments <> rightSegments))+      pure+        [ LoopRelationWitness+            leftIndex+            (rightIndex - leftCount)+            (leftSegments V.! leftIndex)+            (rightSegments V.! (rightIndex - leftCount))+            relation+        | ((ExactSweepSegmentId leftIndex, ExactSweepSegmentId rightIndex), relation) <-+            Map.toAscList (exactSegmentRelationMap plan)+        , leftIndex < leftCount+        , rightIndex >= leftCount+        ]++pointLocationInLoop :: ExactLoop -> ExactPoint -> RegionPointLocation+pointLocationInLoop (ExactLoop points) = pointLocationInCycle points++preparedPointLocation :: PreparedLoop -> ExactPoint -> RegionPointLocation+preparedPointLocation (PreparedLoop (ExactLoop points) bounds _) =+  pointLocationInCycleWithin bounds points++-- | Where a point lies against the closed cycle through the given points:+-- 'RegionOnBoundary' when it lies on a cycle edge, and otherwise the parity of+-- the cycle's edges crossing the rightward ray from it. Any closed point cycle+-- is read, simple or not; for one that is not simple the answer is that+-- parity. Curve nesting reads it on certified chord cycles.+pointLocationInCycle :: NonEmpty ExactPoint -> ExactPoint -> RegionPointLocation+pointLocationInCycle points = pointLocationInCycleWithin (exactPointsBounds points) points++pointLocationInCycleWithin :: ExactBounds -> NonEmpty ExactPoint -> ExactPoint -> RegionPointLocation+pointLocationInCycleWithin bounds points query+  | not (pointInBounds query bounds) = RegionExterior+  | any (\(from, to) -> exactOnClosedSegment from to query) edges = RegionOnBoundary+  | odd (length (filter crossesRay edges)) = RegionInterior+  | otherwise = RegionExterior+ where+  edges = cyclePairs points+  (_, py) = exactPointCoordinates query+  crossesRay (from, to) =+    let (_, ay) = exactPointCoordinates from+        (_, by) = exactPointCoordinates to+        orientation = exactOrient2d from to query+     in (ay <= py && py < by && orientation == GT)+          || (by <= py && py < ay && orientation == LT)++loopWinding :: ExactLoop -> Ordering+loopWinding (ExactLoop points) = cycleWinding points++-- | The sign of the signed area enclosed by the closed chain through the+-- given points: 'GT' counter-clockwise.+cycleWinding :: NonEmpty ExactPoint -> Ordering+cycleWinding points =+  exactSignum+    ( List.foldl'+        (\signedArea (from, to) ->+           signedArea + exactPointCross from to)+        0+        (cyclePairs points)+    )

@@ -30,24 +30,15 @@ import Data.Bifunctor (first) import Data.Foldable (traverse_) import Data.List (sort)-import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Vector as V import Moonlight.Planar.Exact-  ( ExactBounds-  , boundsOverlap-  , pointInBounds-  , ExactPoint-  , ExactSegment+  ( ExactPoint   , SegmentRelation (..)   , exactOnClosedSegment   , exactOrient2d-  , exactPointCross-  , exactPointCoordinates-  , exactSegment   , exactSegmentEndpoints   ) import Moonlight.Planar.Internal.BoundaryCycle@@ -61,8 +52,18 @@   , exactSegmentEventPlan   , exactSegmentRelationMap   )-import Moonlight.Planar.Internal.ExactRational-  ( exactSignum )+import Moonlight.Planar.Internal.Region.Loop+  ( LoopRelationWitness (..)+  , PreparedLoop+  , crossLoopRelations+  , firstPreparedPoint+  , loopSegments+  , loopWinding+  , pointLocationInLoop+  , preparedBounds+  , preparedPointLocation+  , prepareLoop+  ) import Moonlight.Planar.Internal.Region.Publication (labelledPlanarLayer) import Moonlight.Planar.Internal.Region.Bounds   ( componentBounds@@ -86,27 +87,6 @@   , RegionValidationError (..)   ) -data LoopRelationWitness = LoopRelationWitness-  !Int-  !Int-  !ExactSegment-  !ExactSegment-  !SegmentRelation---- | One admitted loop with the bounds and segment vector every relation--- question reads, built once per loop rather than once per pair asked.-data PreparedLoop = PreparedLoop-  !ExactLoop-  !ExactBounds-  !(V.Vector ExactSegment)--prepareLoop :: ExactLoop -> Either RegionValidationError PreparedLoop-prepareLoop loop =-  PreparedLoop loop (exactLoopBounds loop) <$> loopSegments (exactLoopPoints loop)--preparedBounds :: PreparedLoop -> ExactBounds-preparedBounds (PreparedLoop _ bounds _) = bounds- -- | Admit and canonicalize one simple exact cycle. exactLoop :: NonEmpty ExactPoint -> Either RegionValidationError ExactLoop exactLoop submitted = do@@ -277,49 +257,6 @@  where   segmentCount = NonEmpty.length points -loopSegments-  :: NonEmpty ExactPoint-  -> Either RegionValidationError (V.Vector ExactSegment)-loopSegments points =-  V.fromList-    <$> traverse-      (\(from, to) ->-         first (const (RegionLoopDegenerate (NonEmpty.toList points)))-           (exactSegment from to))-      (cyclePairs points)--loopWinding :: ExactLoop -> Ordering-loopWinding (ExactLoop points) =-  exactSignum-    ( List.foldl'-        (\signedArea (from, to) ->-           signedArea + exactPointCross from to)-        0-        (cyclePairs points)-    )--pointLocationInLoop :: ExactLoop -> ExactPoint -> RegionPointLocation-pointLocationInLoop loop = pointLocationInLoopWithin (exactLoopBounds loop) loop--preparedPointLocation :: PreparedLoop -> ExactPoint -> RegionPointLocation-preparedPointLocation (PreparedLoop loop bounds _) = pointLocationInLoopWithin bounds loop--pointLocationInLoopWithin :: ExactBounds -> ExactLoop -> ExactPoint -> RegionPointLocation-pointLocationInLoopWithin bounds loop query-  | not (pointInBounds query bounds) = RegionExterior-  | any (\(from, to) -> exactOnClosedSegment from to query) edges = RegionOnBoundary-  | odd (length (filter crossesRay edges)) = RegionInterior-  | otherwise = RegionExterior- where-  edges = cyclePairs (exactLoopPoints loop)-  (_, py) = exactPointCoordinates query-  crossesRay (from, to) =-    let (_, ay) = exactPointCoordinates from-        (_, by) = exactPointCoordinates to-        orientation = exactOrient2d from to query-     in (ay <= py && py < by && orientation == GT)-          || (by <= py && py < ay && orientation == LT)- componentPointLocation :: PolygonComponent -> ExactPoint -> RegionPointLocation componentPointLocation component query =   case pointLocationInLoop (polygonOuterLoop component) query of@@ -333,30 +270,6 @@       RegionOnBoundary -> RegionOnBoundary       RegionInterior -> RegionExterior -crossLoopRelations-  :: PreparedLoop-  -> PreparedLoop-  -> Either RegionValidationError [LoopRelationWitness]-crossLoopRelations (PreparedLoop _ leftBounds leftSegments) (PreparedLoop _ rightBounds rightSegments)-  | not (boundsOverlap leftBounds rightBounds) = Right []-  | otherwise = do-      let leftCount = V.length leftSegments-      plan <--        first RegionSegmentEventsInvalid-          (exactSegmentEventPlan (leftSegments <> rightSegments))-      pure-        [ LoopRelationWitness-            leftIndex-            (rightIndex - leftCount)-            (leftSegments V.! leftIndex)-            (rightSegments V.! (rightIndex - leftCount))-            relation-        | ((ExactSweepSegmentId leftIndex, ExactSweepSegmentId rightIndex), relation) <--            Map.toAscList (exactSegmentRelationMap plan)-        , leftIndex < leftCount-        , rightIndex >= leftCount-        ]- loopContainsInteriorPoint :: PreparedLoop -> PreparedLoop -> Bool loopContainsInteriorPoint container candidate =   preparedPointLocation container (firstPreparedPoint candidate) == RegionInterior@@ -417,9 +330,6 @@   any     ((== RegionInterior) . componentPointLocation container)     (NonEmpty.toList (exactLoopPoints (polygonOuterLoop candidate)))--firstPreparedPoint :: PreparedLoop -> ExactPoint-firstPreparedPoint (PreparedLoop (ExactLoop (point :| _)) _ _) = point  regionsInteriorsOverlap   :: PlanarRegion

@@ -46,8 +46,6 @@  import Control.DeepSeq (NFData) import Data.Bifunctor (first)-import Data.Bits (shiftL)-import Data.Foldable (foldlM) import qualified Data.Foldable as Foldable import qualified Data.List as List import Data.List.NonEmpty (NonEmpty (..))@@ -55,13 +53,11 @@ import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map.Strict as Map-import Data.Maybe (catMaybes, fromMaybe)+import Data.Maybe (catMaybes) import qualified Data.Ratio as Ratio import qualified Data.Set as Set import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U-import Data.Word (Word64)-import GHC.Float (castDoubleToWord64, castWord64ToDouble) import GHC.Generics (Generic) import Moonlight.Planar.Exact   ( ExactBounds@@ -99,17 +95,31 @@   , cyclePairs   , orderedPair   )-import Moonlight.Planar.Internal.Dyadic (integerBitLength) import Moonlight.Planar.Internal.ExactRational   ( ExactRational-  , exactRationalDenominator+  , PositiveExact   , exactRationalFromDyadic-  , exactRationalFromFiniteDouble   , exactRationalFromNormalizedRatio-  , exactRationalIsZero-  , exactRationalNumerator-  , exactSignum+  , positiveOne+  , positiveTwo+  , ratioPositive   )+import Moonlight.Planar.Internal.Length+  ( CertifiedInterval (..)+  , ExactLengthExpression+  , ExactLengthMeasurement+  , ExactLengthTerm+  , LengthError (..)+  , exactLengthBounds+  , exactLengthExpression+  , exactLengthTerms+  , lengthCoefficient+  , lengthRadicand+  , measureLengthExpression+  , normalizeLengthContributions+  , publicationPrecision+  , scaleLengthExpression+  ) import Moonlight.Planar.Internal.ExactSegmentEvents   ( ExactSegmentEvent (..)   , ExactSegmentEventObstruction@@ -294,42 +304,6 @@               + (fromY * fromY + fromY * toY + toY * toY) * cross         } -data ExactLengthTerm = ExactLengthTerm-  { lengthCoefficient :: !ExactRational-  , lengthRadicand :: !Integer-  }-  deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass (NFData)---- | A normalized sum of rational coefficients times square roots of integer--- radicands. No two radicands differ by a rational square, so equal lengths--- are one term and rational length is the radicand-1 term; each radicand is--- reduced by the square factors of the primes below 64 and by a perfect-square--- cofactor. A squared prime above that bound inside a non-square cofactor is--- beyond factoring-free reach, so the presentation is canonical within an--- expression and across expressions only up to such factors; there is no--- 'Eq' instance for that reason.-newtype ExactLengthExpression = ExactLengthExpression [ExactLengthTerm]-  deriving stock (Show, Generic)-  deriving anyclass (NFData)--exactLengthTerms :: ExactLengthExpression -> [ExactLengthTerm]-exactLengthTerms (ExactLengthExpression terms) = terms--data CertifiedInterval = CertifiedInterval-  { intervalLower :: !Double-  , intervalUpper :: !Double-  }-  deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass (NFData)--data ExactLengthMeasurement = ExactLengthMeasurement-  { exactLengthExpression :: !ExactLengthExpression-  , exactLengthBounds :: !CertifiedInterval-  }-  deriving stock (Show, Generic)-  deriving anyclass (NFData)- data PlanarValuations = PlanarValuations   { valuationEuler :: !EulerCharacteristic   , valuationArea :: !ExactArea@@ -356,11 +330,13 @@       (cellFaceDoubleArea incidence points)       selectedFaceIds   edgeContributions <--    traverse-      ( cellEdgeLengthContribution incidence points selectedFaces-          . UndirectedEdgeId-          . fromIntegral+    Foldable.foldlM+      ( \contributions ->+          cellEdgeLengthContribution incidence points selectedFaces contributions+            . UndirectedEdgeId+            . fromIntegral       )+      []       (IntSet.toAscList selectedEdges)   assembleValuations     (IntMap.size points - IntSet.size selectedEdges + sum (fmap (faceEulerContribution incidence) selectedFaceIds))@@ -393,7 +369,7 @@     euler     doubleArea     ( normalizeLengthContributions-        (\(from, to) -> (oneHalf, segmentSquaredLength from to))+        (\(from, to) -> (positiveHalf, segmentSquaredLength from to))         boundaryAtoms     ) @@ -425,8 +401,18 @@   -> Either ValuationError ExactLengthMeasurement planarValuationsPerimeter valuations =   measureLength-    (scaleLengthExpression 2 (exactLengthExpression (valuationIntrinsic1 valuations)))+    (scaleLengthExpression positiveTwo (exactLengthExpression (valuationIntrinsic1 valuations))) +-- | Valuation lengths are published at the shared owner's binary64+-- publication precision.+measureLength+  :: ExactLengthExpression+  -> Either ValuationError ExactLengthMeasurement+measureLength = first valuationLengthError . measureLengthExpression publicationPrecision++valuationLengthError :: LengthError -> ValuationError+valuationLengthError (LengthNegativeSquare square) = ValuationNegativeSquaredLength square+ cellFaceDoubleArea   :: PlanarIncidence   -> IntMap.IntMap ExactPoint@@ -439,23 +425,29 @@     coordinates <- traverse (cellPoint points . incidenceOrigin incidence) edges     pure (maybe 0 (orientedBoundaryDoubleArea . cyclePairs) (NonEmpty.nonEmpty coordinates)) +-- | Prepend the edge's boundary length contribution: an edge between two+-- selected faces is interior and contributes nothing, an edge with one+-- selected side contributes half, and a wire edge contributes whole. cellEdgeLengthContribution   :: PlanarIncidence   -> IntMap.IntMap ExactPoint   -> IntSet.IntSet+  -> [(PositiveExact, ExactRational)]   -> UndirectedEdgeId-  -> Either ValuationError (ExactRational, ExactRational)-cellEdgeLengthContribution incidence points selectedFaces edge = do-  let (fromVertex, toVertex) = incidenceUndirectedEndpoints incidence edge-      (forward, backward) = directedPair edge-      selected face = IntSet.member (faceIdIndex face) selectedFaces-      coefficient = case (selected (incidenceIncidentFace incidence forward), selected (incidenceIncidentFace incidence backward)) of-        (False, False) -> 1-        (True, True) -> 0-        _ -> oneHalf-  from <- cellPoint points fromVertex-  to <- cellPoint points toVertex-  pure (coefficient, segmentSquaredLength from to)+  -> Either ValuationError [(PositiveExact, ExactRational)]+cellEdgeLengthContribution incidence points selectedFaces rest edge =+  case (selected (incidenceIncidentFace incidence forward), selected (incidenceIncidentFace incidence backward)) of+    (True, True) -> Right rest+    (False, False) -> prepend positiveOne+    _ -> prepend positiveHalf+ where+  (fromVertex, toVertex) = incidenceUndirectedEndpoints incidence edge+  (forward, backward) = directedPair edge+  selected face = IntSet.member (faceIdIndex face) selectedFaces+  prepend coefficient = do+    from <- cellPoint points fromVertex+    to <- cellPoint points toVertex+    pure ((coefficient, segmentSquaredLength from to) : rest)  cellPoint   :: IntMap.IntMap ExactPoint@@ -493,232 +485,6 @@       deltaY = toY - fromY    in deltaX * deltaX + deltaY * deltaY -normalizeLengthContributions-  :: Foldable collection-  => (value -> (ExactRational, ExactRational))-  -> collection value-  -> ExactLengthExpression-normalizeLengthContributions contribution contributions =-  ExactLengthExpression-    [ ExactLengthTerm coefficient radicand-    | (radicand, coefficient) <- List.sortOn fst (concat (Map.elems classes))-    , not (exactRationalIsZero coefficient)-    ]- where-  coefficientsBySquare =-    List.foldl' accumulateContribution Map.empty contributions-  accumulateContribution coefficients value =-    case contribution value of-      (coefficient, square)-        | exactRationalIsZero coefficient -> coefficients-        | otherwise -> Map.insertWith (+) square coefficient coefficients-  classes =-    Map.foldlWithKey' accumulateRadical Map.empty coefficientsBySquare-  accumulateRadical buckets square coefficient =-    let reduced = reduceRadicand square-     in if radicalRadicand reduced == 0-          then buckets-          else-            Map.alter-              ( Just-                  . mergeRadical (coefficient * radicalScale reduced) (radicalRadicand reduced)-                  . fromMaybe []-              )-              (radicalClassKey reduced)-              buckets--data ReducedRadical = ReducedRadical-  { radicalScale :: !ExactRational-  , radicalRadicand :: !Integer-  , radicalClassKey :: !Word64-  }---- | Write √(n/d) as (1/d)·√(n·d), fold the even part of each trial prime's--- multiplicity and a perfect-square cofactor into the scale, and key the--- radicand by what those primes observe of its square class: the parity of--- the multiplicity and the quadratic character of the prime-free part, both--- invariant under multiplication by rational squares.-reduceRadicand :: ExactRational -> ReducedRadical-reduceRadicand square-  | radicand <= 0 = ReducedRadical inverseDenominator radicand 0-  | otherwise =-      let (cofactor, reduced) = List.foldl' stripPrime (radicand, initial) radicalPrimes-          root = integerSquareRoot cofactor-       in if root * root == cofactor-            then reduced {radicalScale = radicalScale reduced * fromInteger root}-            else reduced {radicalRadicand = radicalRadicand reduced * cofactor}- where-  denominator = exactRationalDenominator square-  radicand = exactRationalNumerator square * denominator-  inverseDenominator = exactRationalFromNormalizedRatio (1 Ratio.% denominator)-  initial = ReducedRadical inverseDenominator 1 0-  stripPrime (remaining, reduced) (prime, residues) =-    let (multiplicity, rest) = primeMultiplicity prime remaining-        (halfPower, parity) = multiplicity `divMod` 2-        character = squareClassCharacter prime residues rest-     in ( rest-        , ReducedRadical-            { radicalScale = radicalScale reduced * fromInteger (prime ^ halfPower)-            , radicalRadicand = radicalRadicand reduced * prime ^ parity-            , radicalClassKey = radicalClassKey reduced * 8 + fromIntegral (parity * 4 + character)-            }-        )--radicalPrimes :: [(Integer, IntSet.IntSet)]-radicalPrimes =-  [ (toInteger prime, IntSet.fromList [(x * x) `mod` prime | x <- [1 .. prime - 1]])-  | prime <- [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61 :: Int]-  ]--primeMultiplicity :: Integer -> Integer -> (Int, Integer)-primeMultiplicity prime = go 0- where-  go !count value =-    case value `quotRem` prime of-      (quotient, 0) -> go (count + 1) quotient-      _ -> (count, value)--squareClassCharacter :: Integer -> IntSet.IntSet -> Integer -> Int-squareClassCharacter 2 _ rest = fromInteger ((rest `mod` 8) `div` 2)-squareClassCharacter prime residues rest =-  if IntSet.member (fromInteger (rest `mod` prime)) residues then 1 else 0---- | Fold a term into its square class: the product of two radicands of one--- class is a perfect square, whose root exposes the rational square relating--- them, so both fold onto their common divisor with integer scales.-mergeRadical-  :: ExactRational-  -> Integer-  -> [(Integer, ExactRational)]-  -> [(Integer, ExactRational)]-mergeRadical coefficient radicand = go- where-  go [] = [(radicand, coefficient)]-  go ((kernel, total) : rest)-    | pairRoot * pairRoot == pairProduct =-        let common = gcd pairRoot kernel-            newScale = pairRoot `div` common-            oldScale = kernel `div` common-         in ( kernel `div` (oldScale * oldScale)-            , total * fromInteger oldScale + coefficient * fromInteger newScale-            )-              : rest-    | otherwise = (kernel, total) : go rest-   where-    pairProduct = radicand * kernel-    pairRoot = integerSquareRoot pairProduct--scaleLengthExpression-  :: Integer-  -> ExactLengthExpression-  -> ExactLengthExpression-scaleLengthExpression scalar (ExactLengthExpression terms) =-  let exactScalar = fromInteger scalar-   in ExactLengthExpression-        [ term-            { lengthCoefficient =-                exactScalar * lengthCoefficient term-            }-        | term <- terms-        ]--measureLength-  :: ExactLengthExpression-  -> Either ValuationError ExactLengthMeasurement-measureLength expression@(ExactLengthExpression terms) = do-  (lower, upper) <--    foldlM-      addTermBounds-      (0, 0)-      terms-  pure-    ExactLengthMeasurement-      { exactLengthExpression = expression-      , exactLengthBounds =-          CertifiedInterval-            { intervalLower = directedLowerDouble lower-            , intervalUpper = directedUpperDouble upper-            }-      }- where-  addTermBounds (lowerTotal, upperTotal) term = do-    (lowerRoot, upperRoot) <- exactSquareRootBounds (fromInteger (lengthRadicand term))-    let coefficient = lengthCoefficient term-    pure-      ( lowerTotal + coefficient * lowerRoot-      , upperTotal + coefficient * upperRoot-      )--exactSquareRootBounds-  :: ExactRational-  -> Either ValuationError (ExactRational, ExactRational)-exactSquareRootBounds value =-  case exactSignum value of-    LT -> Left (ValuationNegativeSquaredLength value)-    _ ->-      let numerator = exactRationalNumerator value-          denominator = exactRationalDenominator value-          scale = 1 `shiftL` radicalPrecisionBits-          scaledNumerator = numerator * scale * scale-          root = integerSquareRoot (scaledNumerator `div` denominator)-          exact = root * root * denominator == scaledNumerator-          dyadicPower = negate radicalPrecisionBits-       in Right-            ( exactRationalFromDyadic root dyadicPower-            , exactRationalFromDyadic (if exact then root else root + 1) dyadicPower-            )--radicalPrecisionBits :: Int-radicalPrecisionBits = 128--integerSquareRoot :: Integer -> Integer-integerSquareRoot value-  | value < 2 = value-  | otherwise = descend initial- where-  initial = 1 `shiftL` ((integerBitLength value + 1) `div` 2)-  descend estimate =-    let refined = (estimate + value `div` estimate) `div` 2-     in if refined >= estimate then estimate else descend refined--directedLowerDouble :: ExactRational -> Double-directedLowerDouble value =-  let candidate = rationalToDouble value-   in if isInfinite candidate-        then maximumFiniteDouble-        else-          if exactRationalFromFiniteDouble candidate <= value-            then candidate-            else previousPositiveDouble candidate--directedUpperDouble :: ExactRational -> Double-directedUpperDouble value =-  let candidate = rationalToDouble value-   in if isInfinite candidate-        || exactRationalFromFiniteDouble candidate >= value-        then candidate-        else nextPositiveDouble candidate--rationalToDouble :: ExactRational -> Double-rationalToDouble value =-  fromRational-    ( exactRationalNumerator value-        Ratio.% exactRationalDenominator value-    )--previousPositiveDouble :: Double -> Double-previousPositiveDouble value-  | value <= 0 = 0-  | otherwise = castWord64ToDouble (castDoubleToWord64 value - 1)--nextPositiveDouble :: Double -> Double-nextPositiveDouble value-  | value == 0 = castWord64ToDouble 1-  | otherwise = castWord64ToDouble (castDoubleToWord64 value + 1)--maximumFiniteDouble :: Double-maximumFiniteDouble = castWord64ToDouble 0x7fefffffffffffff- data ComponentBoundaryData = ComponentBoundaryData   { componentBoundaryEuler :: !Int   , componentBoundaryBounds :: !ExactBounds@@ -892,6 +658,9 @@  oneHalf :: ExactRational oneHalf = exactRationalFromDyadic 1 (-1)++positiveHalf :: PositiveExact+positiveHalf = ratioPositive positiveOne positiveTwo  oneSixth :: ExactRational oneSixth = exactRationalFromNormalizedRatio (1 Ratio.% 6)

@@ -11,10 +11,11 @@   , arrangeMotifs   ) where -import Data.Foldable (toList)+import qualified Data.Foldable as Foldable import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty import Data.Semigroup (Max (..))-import Data.Sequence (Seq, ViewL (..))+import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Traversable (mapAccumL) import Moonlight.Planar.Affine@@ -24,7 +25,7 @@   , location, pathSubpaths, stepControlPoints, trailSteps ) import Moonlight.Planar.Exact   ( ExactBounds, ExactPoint, ExactRational, ExactVector (..), UnitInterval-  , boundsMaximumX, boundsMaximumY, boundsMinimumX, boundsMinimumY+  , boundsMaximumX, boundsMaximumY, boundsMinimumX, boundsMinimumY, boundsUnion   , exactPointCoordinates, exactPointsBounds, translateExactPoint, unitIntervalValue ) import Moonlight.Planar.Illustration (Picture, PictureAlgebra (..), foldPicture) import Moonlight.Planar.Illustration.Motif (Motif, motifPicture, transformMotif)@@ -41,33 +42,53 @@ -- | Each control point is transformed once after accumulating enclosing maps. -- A located empty trail retains its anchor; an empty path/picture stays empty. geometryEnvelope :: Picture part -> GeometryEnvelope-geometryEnvelope picture = foldPicture algebra picture identityAffine2+geometryEnvelope = GeometryEnvelope . foldControls (Seq.|>) Seq.empty++-- The bounds of that same support, reduced without materialising it.+controlBounds :: Picture part -> Maybe ExactBounds+controlBounds = foldControls includeBounds Nothing++-- The sole traversal of located controls: a strict left fold under the fully+-- composed frame. A trail visits its anchor, then each step's controls after+-- the start, since that start is the previous end (or the anchor) already visited.+foldControls :: forall acc part. (acc -> ExactPoint -> acc) -> acc -> Picture part -> acc+foldControls visit start picture = foldPicture algebra picture identityAffine2 start  where-  algebra :: PictureAlgebra part (Affine2 -> GeometryEnvelope)+  algebra :: PictureAlgebra part (Affine2 -> acc -> acc)   algebra = PictureAlgebra-    { paintSequence = \children frame -> foldMap ($ frame) children-    , paintFill = \_ _ contours frame -> foldMap (subpathEnvelope frame . ClosedSubpath) contours-    , paintStroke = \_ curve frame -> foldMap (subpathEnvelope frame) (pathSubpaths curve)+    { paintSequence = \children frame acc -> Foldable.foldl' (\inner child -> child frame inner) acc children+    , paintFill = \_ _ contours frame acc ->+        Foldable.foldl' (\inner -> subpath frame inner . ClosedSubpath) acc contours+    , paintStroke = \_ curve frame acc -> Foldable.foldl' (subpath frame) acc (pathSubpaths curve)     , paintClip = \_ _ child -> child     , paintPlace = \local child outer -> child (composeAffine2 outer local)     , paintOpacity = \_ child -> child     , paintAnnotation = \_ child -> child     }+  subpath :: Affine2 -> acc -> Subpath -> acc+  subpath frame acc value = case value of+    OpenSubpath located -> trail frame acc (location located) (trailSteps (locatedValue located))+    ClosedSubpath located -> trail frame acc (location located) (closedTrailSteps (locatedValue located))+  trail :: Affine2 -> acc -> ExactPoint -> Seq CurveStep -> acc+  trail frame acc anchor steps = case Foldable.foldl' advance (Cursor anchor (emit acc anchor)) steps of+    Cursor _ total -> total+   where+    emit :: acc -> ExactPoint -> acc+    emit inner point = let !placed = transformPoint frame point in visit inner placed+    advance :: Cursor acc -> CurveStep -> Cursor acc+    advance (Cursor origin inner) step = Cursor (translateExactPoint origin (curveStepEnd step))+      (Foldable.foldl' (\current -> emit current . translateExactPoint origin) inner+        (NonEmpty.tail (stepControlPoints step))) -subpathEnvelope :: Affine2 -> Subpath -> GeometryEnvelope-subpathEnvelope frame subpath = case subpath of-  OpenSubpath value -> controlsEnvelope frame (location value) (trailSteps (locatedValue value))-  ClosedSubpath value -> controlsEnvelope frame (location value) (closedTrailSteps (locatedValue value))+-- A step's start and the running total, both forced at every step.+data Cursor acc = Cursor !ExactPoint !acc -controlsEnvelope :: Affine2 -> ExactPoint -> Seq CurveStep -> GeometryEnvelope-controlsEnvelope frame anchor steps = GeometryEnvelope $-  Seq.singleton (transformPoint frame anchor) <> foldMap id (snd (mapAccumL advance anchor steps))+-- Strict: each union is forced before the next point arrives.+includeBounds :: Maybe ExactBounds -> ExactPoint -> Maybe ExactBounds+includeBounds bounds point = Just $! maybe single (`boundsUnion` single) bounds  where-  advance :: ExactPoint -> CurveStep -> (ExactPoint, Seq ExactPoint)-  advance origin step =-    ( translateExactPoint origin (curveStepEnd step)-    , Seq.fromList (toList (transformPoint frame . translateExactPoint origin <$> stepControlPoints step))-    )+  single :: ExactBounds+  single = exactPointsBounds (point :| [])  transformGeometryEnvelope :: Affine2 -> GeometryEnvelope -> GeometryEnvelope transformGeometryEnvelope frame (GeometryEnvelope points) =@@ -82,9 +103,7 @@   project point = let (px, py) = exactPointCoordinates point in x * px + y * py  geometryBounds :: GeometryEnvelope -> Maybe ExactBounds-geometryBounds (GeometryEnvelope points) = case Seq.viewl points of-  EmptyL -> Nothing-  first :< rest -> Just (exactPointsBounds (first :| toList rest))+geometryBounds (GeometryEnvelope points) = Foldable.foldl' includeBounds Nothing points  data LayoutAxis = Horizontal | Vertical   deriving stock (Eq, Ord, Show)@@ -92,7 +111,7 @@ -- | Align a minimum (0), midpoint (1/2), maximum (1), or interpolated edge. -- Empty geometry remains unchanged; the perpendicular coordinate is retained. alignMotif :: LayoutAxis -> UnitInterval -> ExactRational -> Motif port part -> Motif port part-alignMotif axis fraction target value = case geometryBounds (geometryEnvelope (motifPicture value)) of+alignMotif axis fraction target value = case controlBounds (motifPicture value) of   Nothing -> value   Just bounds ->     let (lo, hi) = axisInterval axis bounds@@ -105,7 +124,7 @@ arrangeMotifs axis gap values = snd (mapAccumL arrange Nothing (measure <$> values))  where   measure :: Motif port part -> (Motif port part, Maybe (ExactRational, ExactRational))-  measure value = (value, axisInterval axis <$> geometryBounds (geometryEnvelope (motifPicture value)))+  measure value = (value, axisInterval axis <$> controlBounds (motifPicture value))   arrange :: Maybe ExactRational -> (Motif port part, Maybe (ExactRational, ExactRational))           -> (Maybe ExactRational, Motif port part)   arrange edge (value, Nothing) = (edge, value)

@@ -6,8 +6,28 @@ import Moonlight.Planar.Exact (ExactPoint, exactPoint, exactRationalNumerator, exactRationalDenominator) import Moonlight.Planar.Internal.ExactRational   ( ExactRational+  , PositiveExact   , exactRational+  , positiveOne+  , positiveTwo   )+import Moonlight.Planar.Internal.Length+  ( ExactLengthExpression+  , LengthEnclosure+  , LengthError (..)+  , RadicalPrecision+  , RadicalPrecisionError (..)+  , certifiedInterval+  , expressionEnclosure+  , lengthEnclosureLower+  , lengthEnclosureUpper+  , lengthEnclosureWidth+  , normalizeLengthContributions+  , publicationPrecision+  , radicalPrecision+  , radicalPrecisionBits+  , squareRootEnclosure+  ) import Moonlight.Planar.Overlay   ( overlayClosedIntersection   , overlayClosedUnion@@ -66,6 +86,7 @@   testDimensionalCellFixtures   testMetricInvariance   testRadicalNormalForm+  testLengthEnclosures   putStrLn "valuation: ok"  testExactPlanarMoments :: IO ()@@ -448,3 +469,95 @@       (orientedBoundaryMoments prefix <> orientedBoundaryMoments suffix)     assertEqual (label <> " empty boundary identity") actual       (orientedBoundaryMoments [] <> actual)++-- | The shared length owner at admitted precisions. Containment is checked+-- by exact squaring, not against a floating square root.+testLengthEnclosures :: IO ()+testLengthEnclosures = do+  assertEqual "zero precision refused" (Left (NonPositiveRadicalPrecision 0)) (radicalPrecision 0)+  assertEqual "negative precision refused"+    (Left (NonPositiveRadicalPrecision (-3))) (radicalPrecision (-3))+  -- The doubled shift count stays representable: the boundary is admitted,+  -- one past it refused. Neither is used to take a root.+  assertEqual "largest representable precision admitted"+    (Right (maxBound `quot` 2)) (radicalPrecisionBits <$> radicalPrecision (maxBound `quot` 2))+  assertEqual "unrepresentable precision refused"+    (Left (UnrepresentableRadicalPrecision (maxBound `quot` 2 + 1)))+    (radicalPrecisionBits <$> radicalPrecision (maxBound `quot` 2 + 1))+  precisions <- traverse (requireRight "radical precision" . radicalPrecision) [1, 16, 64, 128, 256]+  oneThird <- exactValue 1 3+  nineQuarters <- exactValue 9 4+  threeHalves <- exactValue 3 2+  tiny <- exactValue 1 (2 ^ (80 :: Int))+  let squares = [0, 1, 2, 3, 4, 327697, 10 ^ (40 :: Int) + 1, oneThird, nineQuarters, tiny]+  traverse_ (checkSquare precisions) squares+  traverse_ (\precision -> do+    zeroRoot <- requireRight "zero root" (squareRootEnclosure precision 0)+    assertEqual "zero has a zero-width root" (0, 0) (endpoints zeroRoot)+    exactRoot <- requireRight "exact dyadic root" (squareRootEnclosure precision nineQuarters)+    assertEqual "an exact dyadic square has a zero-width root" (threeHalves, threeHalves) (endpoints exactRoot)+    empty <- requireRight "empty expression" (expressionEnclosure precision (lengthExpression []))+    assertEqual "the empty expression encloses zero exactly" (0, 0) (endpoints empty)+    assertEqual "negative square refused" (Left (LengthNegativeSquare (-1))) (squareRootEnclosure precision (-1))) precisions++  -- Positive coefficients scale each class's root enclosure; the normalizer+  -- folds sqrt 8 onto 2 sqrt 2 before any root is bounded.+  traverse_ (\precision -> do+    rootTwo <- requireRight "root two" (squareRootEnclosure precision 2)+    rootThree <- requireRight "root three" (squareRootEnclosure precision 3)+    let expected =+          ( 2 * lengthEnclosureLower rootTwo + lengthEnclosureLower rootThree+          , 2 * lengthEnclosureUpper rootTwo + lengthEnclosureUpper rootThree )+    scaled <- requireRight "scaled sum"+      (expressionEnclosure precision (lengthExpression [(positiveTwo, 2), (positiveOne, 3)]))+    merged <- requireRight "merged sum"+      (expressionEnclosure precision (lengthExpression [(positiveOne, 8), (positiveOne, 3)]))+    assertEqual "coefficients scale their root enclosures" expected (endpoints scaled)+    assertEqual "square classes merge before rounding" expected (endpoints merged)) precisions++  -- The irrational triangle's perimeter 2 + sqrt 2 at growing precision.+  triangle <- polygonRegion [(0, 0), (1, 0), (0, 1)]+  perimeter <- requireRight "irrational triangle perimeter" (regionPerimeter triangle)+  enclosures <- traverse+    (\precision -> requireRight "perimeter enclosure"+      (expressionEnclosure precision (exactLengthExpression perimeter))) precisions+  traverse_ (\(coarse, fine) -> do+    assertEqual "finer enclosures nest" True (nested fine coarse)+    assertEqual "finer enclosures are no wider" True+      (lengthEnclosureWidth fine <= lengthEnclosureWidth coarse)) (zip enclosures (drop 1 enclosures))+  assertEqual "enclosures contain 2 + sqrt 2" True+    (all (\enclosure -> containsRoot 2 (lengthEnclosureLower enclosure - 2)+      (lengthEnclosureUpper enclosure - 2)) enclosures)+  published <- requireRight "publication enclosure"+    (expressionEnclosure publicationPrecision (exactLengthExpression perimeter))+  assertEqual "valuation publishes the owner's 128-bit enclosure"+    (certifiedInterval published) (exactLengthBounds perimeter)+  assertEqual "binary64 publication is outward" True (outward published)+  traverse_ (\enclosure -> assertEqual "binary64 publication is outward" True (outward enclosure)) enclosures+ where+  endpoints enclosure = (lengthEnclosureLower enclosure, lengthEnclosureUpper enclosure)+  lengthExpression :: [(PositiveExact, ExactRational)] -> ExactLengthExpression+  lengthExpression = normalizeLengthContributions id+  checkSquare :: [RadicalPrecision] -> ExactRational -> IO ()+  checkSquare precisions square = do+    roots <- traverse (\precision -> requireRight "square root" (squareRootEnclosure precision square)) precisions+    assertEqual "roots enclose by exact squaring" True+      (all (\root -> containsRoot square (lengthEnclosureLower root) (lengthEnclosureUpper root)) roots)+    assertEqual "root width is at most one unit in the last place" True+      (and (zipWith (\bits root -> lengthEnclosureWidth root * 2 ^ bits <= 1) [1 :: Int, 16, 64, 128, 256] roots))+    traverse_ (\(coarse, fine) -> assertEqual "root enclosures nest" True (nested fine coarse))+      (zip roots (drop 1 roots))+  nested :: LengthEnclosure -> LengthEnclosure -> Bool+  nested inner outer =+    lengthEnclosureLower outer <= lengthEnclosureLower inner+      && lengthEnclosureUpper inner <= lengthEnclosureUpper outer+  containsRoot :: ExactRational -> ExactRational -> ExactRational -> Bool+  containsRoot square lower upper = lower <= upper && (lower <= 0 || lower * lower <= square)+    && upper >= 0 && square <= upper * upper+  outward :: LengthEnclosure -> Bool+  outward enclosure =+    let interval = certifiedInterval enclosure+     in toRational (intervalLower interval) <= rational (lengthEnclosureLower enclosure)+          && rational (lengthEnclosureUpper enclosure) <= toRational (intervalUpper interval)+  rational :: ExactRational -> Rational+  rational value = exactRationalNumerator value % exactRationalDenominator value

@@ -2,9 +2,14 @@  import qualified Moonlight.Planar.AffineSpec as Affine import qualified Moonlight.Planar.CurveSpec as Curve+import qualified Moonlight.Planar.CurveMeasureSpec as Measure+import qualified Moonlight.Planar.CurveSourceSpec as Source+import qualified Moonlight.Planar.CurveCertificateSpec as Certificate+import qualified Moonlight.Planar.CurveProximitySpec as Proximity+import qualified Moonlight.Planar.CurveFrameSpec as Frame import qualified Moonlight.Planar.Curve.AuthoringSpec as Authoring import qualified Moonlight.Planar.CurveLoweringSpec as Lowering import qualified Moonlight.Planar.RegionAdmissionSpec as Region  main :: IO ()-main = () <$ sequenceA [Curve.tests, Authoring.tests, Affine.tests, Lowering.tests, Region.tests]+main = () <$ sequenceA [Curve.tests, Measure.tests, Source.tests, Frame.tests, Authoring.tests, Affine.tests, Lowering.tests, Certificate.tests, Proximity.tests, Region.tests]

@@ -0,0 +1,409 @@+-- | Curve certificate and certified region laws: every returned witness+-- discharges the strict inequality it advertises; a region is lowered only+-- inside the certified domain, with a crossing reported by its certificate,+-- an unresolved tangency or cusp by the budget it spent, and a lowered+-- polygon that nests otherwise than its curves refused.+module Moonlight.Planar.CurveCertificateSpec (tests) where++import Control.Monad (unless)+import Data.Foldable (toList, traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Sequence as Seq+import Moonlight.Planar.Affine (identityAffine2)+import Moonlight.Planar.Curve+  ( ClosedTrail, CurveStep, Located, closeWith, cubic, curveStep, curveStepEnd, line, locate+  , openTrail, quadratic, rationalQuadratic, stepControlPoints )+import Moonlight.Planar.Curve.Lowering (LoweringPolicy, loweringPolicy)+import Moonlight.Planar.Curve.Region+import Moonlight.Planar.Exact+  ( ExactPoint, ExactRational, ExactVector (..), divideByPositive, exactOrient2d, exactPoint+  , exactPointCoordinates, exactRational, positiveExact, positiveOne, positiveTwo, unitOne, unitZero )+import qualified Moonlight.Planar.Internal.CurveCertificate as Certificate+import Moonlight.Planar.Internal.CurveCertificate+  ( CrossingVerdict (..), halfPlaneWitness, hullGap, hullSeparation, jointWitness+  , monotoneWitness, separatingAxis, stationaryPiece )+import Moonlight.Planar.Region (RegionPointLocation (..), regionPointLocation)+import Support (assertEqual, requireRight)++tests :: IO ()+tests = sequence_+  [ testHalfPlane+  , testSeparation+  , testPieceWitnesses+  , testCrossingVerdicts+  , testCertifiedRegions+  , testRefusedRegions+  , testBudgetRefusals+  , testPolygonTopology+  , putStrLn "curve certificate: ok"+  ]++-- A returned half-plane witness is strictly positive on every nonzero input,+-- and one exists whenever the nonzero inputs lie in an open half-plane.+testHalfPlane :: IO ()+testHalfPlane = do+  let cases =+        [ ("antipodal pair", [v 1 0, v (-1) 0], False)+        , ("zero vectors only", [v 0 0], False)+        , ("open cone wider than a right angle", [v 1 0, v (-1) 1, v 0 1], True)+        , ("parallel inputs", [v 2 1, v 4 2, v 0 0], True)+        , ("three directions spanning the plane", [v 1 0, v (-1) 1, v (-1) (-1)], False)+        ]+  traverse_+    (\(label, vectors, expected) -> case halfPlaneWitness vectors of+        Nothing -> assertEqual ("half-plane: " <> label) expected False+        Just direction -> do+          assertEqual ("half-plane: " <> label) expected True+          assert ("half-plane witness is strict: " <> label)+            (all (\vector -> vector == v 0 0 || dot direction vector > 0) vectors))+    cases++-- A returned axis puts every point of the first set strictly below every+-- point of the second; touching or crossing hulls have none. The hull gap+-- is the distance between the hulls.+testSeparation :: IO ()+testSeparation = do+  let cases =+        [ ("touching segments", p 0 0 :| [p 1 1], p 1 1 :| [p 2 0], False)+        , ("collinear disjoint segments", p 0 0 :| [p 1 0], p 2 0 :| [p 3 0], True)+        , ("crossing segments", p 0 0 :| [p 2 2], p 0 2 :| [p 2 0], False)+        , ("point beside a triangle", p 3 3 :| [], p 0 0 :| [p 2 0, p 0 2], True)+        , ("point on a triangle edge", p 1 1 :| [], p 0 0 :| [p 2 0, p 0 2], False)+        ]+  traverse_+    (\(label, lower, upper, expected) -> case separatingAxis lower upper of+        Nothing -> assertEqual ("separation: " <> label) expected False+        Just axis -> do+          assertEqual ("separation: " <> label) expected True+          assert ("separating axis is strict: " <> label)+            (all (\a -> all (\b -> project axis a < project axis b) upper) lower))+    cases+  -- The hull gap is the hulls' distance, exactly in square, against a brute+  -- force independent of the candidate axes: when the hulls meet, zero, and+  -- otherwise the least squared distance from a point of either set to a+  -- segment between two points of the other. Diagonals inside a hull are+  -- never nearer than its edges, so the brute force is the hull distance.+  traverse_+    (\(label, lower, upper, squared) -> do+        assertEqual ("hull gap by hand: " <> label) squared (squaredGap lower upper)+        assertEqual ("hull gap by brute force: " <> label) (bruteGap lower upper) (squaredGap lower upper))+    [ ("separated boxes", p 0 0 :| [p 1 0, p 1 1, p 0 1], p 3 2 :| [p 4 2, p 4 3, p 3 3], 5)+    , ("vertex nearest an edge interior", p 3 3 :| [], p 0 0 :| [p 2 0, p 0 2], 8)+    , ("edge interior nearest a vertex, either way round", p 0 0 :| [p 2 0, p 0 2], p 3 3 :| [], 8)+    , ("point off a triangle vertex", p 5 (-1) :| [], p 0 0 :| [p 2 0, p 0 2], 10)+    , ("collinear disjoint segments", p 0 0 :| [p 1 0], p 2 0 :| [p 3 0], 1)+    , ("parallel edges", p 0 0 :| [p 2 0, p 1 (-1)], p 1 (r 1 2) :| [p 3 (r 1 2), p 2 1], r 1 4)+    , ("overlapping hulls", p 0 0 :| [p 2 2], p 0 2 :| [p 2 0], 0)+    , ("touching segments", p 0 0 :| [p 1 1], p 1 1 :| [p 2 0], 0)+    , ("coincident points", p 1 1 :| [], p 1 1 :| [], 0)+    ]+  -- Every segment on a lattice against a fixed triangle.+  let triangle = p 0 0 :| [p 2 0, p 0 2]+      lattice = [p (fromInteger x) (fromInteger y) | x <- [-1 .. 4], y <- [-1 .. 4]]+      mismatches =+        [ (a, b)+        | a <- lattice, b <- lattice+        , let segment = a :| [b]+        , squaredGap triangle segment /= bruteGap triangle segment ]+  assertEqual "hull gap by brute force over lattice segments" [] mismatches+ where+  squaredGap lower upper = let gap = hullGap lower upper in dot gap gap++-- The squared distance between two hulls without the candidate axes: zero+-- when a segment of one meets a segment of the other or a point of one lies+-- in the other's triangle fan, and otherwise the least point-to-segment+-- distance.+bruteGap :: NonEmpty ExactPoint -> NonEmpty ExactPoint -> ExactRational+bruteGap lower upper+  | meets = 0+  | otherwise = case distances of+      nearest : others -> foldr min nearest others+      [] -> 0+ where+  lows = toList lower+  highs = toList upper+  segments :: [ExactPoint] -> [(ExactPoint, ExactPoint)]+  segments points = [(a, b) | a <- points, b <- points]+  meets =+    or [segmentsMeet a b c d | (a, b) <- segments lows, (c, d) <- segments highs]+      || any (inFan lows) highs || any (inFan highs) lows+  distances = [pointSegment x s | x <- lows, s <- segments highs] <> [pointSegment x s | x <- highs, s <- segments lows]++-- Whether a point lies in some triangle of three of the points, boundary+-- included: the hull is the union of such triangles.+inFan :: [ExactPoint] -> ExactPoint -> Bool+inFan points x =+  or [ all (/= LT) orientations || all (/= GT) orientations+     | a <- points, b <- points, c <- points+     , exactOrient2d a b c /= EQ+     , let orientations = [exactOrient2d a b x, exactOrient2d b c x, exactOrient2d c a x] ]++segmentsMeet :: ExactPoint -> ExactPoint -> ExactPoint -> ExactPoint -> Bool+segmentsMeet a b c d =+  (o1 /= o2 && o3 /= o4 && all (/= EQ) [o1, o2, o3, o4])+    || (o1 == EQ && within a b c) || (o2 == EQ && within a b d)+    || (o3 == EQ && within c d a) || (o4 == EQ && within c d b)+ where+  o1 = exactOrient2d a b c+  o2 = exactOrient2d a b d+  o3 = exactOrient2d c d a+  o4 = exactOrient2d c d b+  within s t x =+    let (sx, sy) = exactPointCoordinates s+        (tx, ty) = exactPointCoordinates t+        (xx, xy) = exactPointCoordinates x+     in min sx tx <= xx && xx <= max sx tx && min sy ty <= xy && xy <= max sy ty++pointSegment :: ExactPoint -> (ExactPoint, ExactPoint) -> ExactRational+pointSegment x (s, t) = squaredLength (difference (offset nearest) (offset x))+ where+  direction = difference (offset t) (offset s)+  along = case positiveExact (dot direction direction) of+    Right length2 -> max 0 (min 1 (divideByPositive (dot (difference (offset x) (offset s)) direction) length2))+    Left _ -> 0+  nearest = let (sx, sy) = exactPointCoordinates s; ExactVector dx dy = direction in p (sx + along * dx) (sy + along * dy)+  offset point = let (px, py) = exactPointCoordinates point in ExactVector px py+  squaredLength vector = dot vector vector++testPieceWitnesses :: IO ()+testPieceWitnesses = do+  let sCurve = curveStep (cubic (v 1 2) (v 2 (-1))) (v 3 1)+      loopy = curveStep (cubic (v 2 1) (v (-1) 1)) (v 1 0)+      bulge = curveStep (rationalQuadratic (v 1 1) positiveOne positiveTwo) (v 0 2)+  assertEqual "monotone: s-curve" True (advances sCurve)+  assertEqual "monotone: rational bulge" True (advances bulge)+  assertEqual "monotone: looping cubic" False (advances loopy)+  assertEqual "monotone: stationary step" False (advances (curveStep line (v 0 0)))+  assertEqual "stationary: zero line" True (stationaryPiece (curveStep line (v 0 0)))+  assertEqual "stationary: returning cubic moves" False (stationaryPiece (curveStep (cubic (v 1 0) (v 1 0)) (v 0 0)))+  let joins =+        [ ("smooth continuation", curveStep line (v 1 0), curveStep line (v 1 1), True)+        , ("sharp corner", curveStep line (v 1 0), curveStep line (v (-1) 1), True)+        , ("reversal cusp", curveStep line (v 1 0), curveStep line (v (-1) 0), False)+        , ( "quadratic cusp"+          , curveStep (quadratic (v 1 0)) (v 1 1), curveStep (quadratic (v 0 (-1))) (v 1 (-1)), False )+        ]+  traverse_+    (\(label, incoming, outgoing, expected) -> case jointWitness incoming outgoing of+        Nothing -> assertEqual ("joint: " <> label) expected False+        Just direction -> do+          assertEqual ("joint: " <> label) expected True+          assert ("joint witness is strict: " <> label)+            (all (\c -> c == curveStepEnd incoming || dot direction (difference c (curveStepEnd incoming)) > 0)+                (toList (stepControlPoints incoming))+              && all (\c -> c == v 0 0 || dot direction c < 0) (toList (stepControlPoints outgoing))))+    joins+ where+  advances step = case monotoneWitness step of+    Nothing -> False+    Just direction -> all (\edge -> edge == v 0 0 || dot direction edge > 0) (edges step)+  edges step = let points = toList (stepControlPoints step) in zipWith difference (drop 1 points) points++-- The verdict needs both cones and all four endpoints clear; the parabola+-- y = x^2 against its tangent at (1/3, 1/9) never receives one.+testCrossingVerdicts :: IO ()+testCrossingVerdicts = do+  budget <- requireRight "budget" (subdivisionBudget 12 4096 4096)+  narrow <- requireRight "one bit" (subdivisionBudget 12 4096 1)+  let crossingVerdict = Certificate.crossingVerdict budget+      monotoneQuadratic = curveStep (quadratic (v (r 1 2) 0)) (v 1 1)+      antiDiagonal = curveStep line (v 1 (-1))+      parabola = curveStep (quadratic (v 1 (-2))) (v 2 0)+      tangent = curveStep line (v 1 (r 2 3))+  assertEqual "crossing: monotone quadratic meets the anti-diagonal once" (Right (Just True))+    (fmap single <$> crossingVerdict (p 0 0) monotoneQuadratic (p 0 1) antiDiagonal)+  assertEqual "crossing: a far anti-diagonal is certified clear" (Right (Just False))+    (fmap single <$> crossingVerdict (p 0 0) monotoneQuadratic (p 2 3) antiDiagonal)+  assertEqual "crossing: a tangent line has no verdict" (Right Nothing)+    (fmap single <$> crossingVerdict (p (-1) 1) parabola (p 0 (r (-1) 9)) tangent)+  assertEqual "crossing: a non-monotone parabola has no verdict" (Right Nothing)+    (fmap single <$> crossingVerdict (p (-1) 1) parabola (p (-1) (r 1 2)) (curveStep line (v 2 0)))+  -- A certificate is returned only admitted: under one bit it is refused.+  case Certificate.crossingVerdict narrow (p 0 0) monotoneQuadratic (p 0 1) antiDiagonal of+    Left (BitsExhausted width) -> assert "certificate wider than one bit" (width > 1)+    other -> fail ("certificate admitted under one bit: " <> show (fmap single <$> other))+  assertEqual "hull: a far line is separated from the parabola" True+    (hullSeparation (p (-1) 1) parabola (p (-1) 5) (curveStep line (v 2 0)) /= Nothing)+ where+  single verdict = case verdict of+    SingleCrossing _ -> True+    NoCrossing _ -> False++testCertifiedRegions :: IO ()+testCertifiedRegions = do+  budget <- requireRight "budget" (subdivisionBudget 12 4096 4096)+  policy <- fine+  (region, receipts, evidence) <- requireRight "square with hole"+    (lowerSimpleRegion policy budget [CurveComponent square [squareHole]])+  assertEqual "one receipt per contour" 2 (length receipts)+  assertEqual "square pieces" [(ContourRef 0 OuterContour, 4), (ContourRef 0 (HoleContour 0), 4)]+    (certifiedPieceCounts evidence)+  -- Away from every piece hull the certificate agrees with the admitted+  -- polygon; on a hull it does not decide.+  traverse_+    (\point -> assertEqual "certified location agrees with the polygon"+        (Just (regionPointLocation region point)) (certifiedPointLocation evidence point))+    [p 3 3, p (r 3 2) (r 3 2), p 5 5, p (-1) 2]+  assertEqual "no certified location on a hull" [Nothing, Nothing]+    (map (certifiedPointLocation evidence) [p 1 1, p 2 1])+  (_, _, rings) <- requireRight "concentric circles"+    (lowerSimpleRegion policy budget [CurveComponent (ring True 0 0 2) [ring False 0 0 1]])+  assertEqual "annulus interior" (Just RegionInterior) (certifiedPointLocation rings (p (r 3 2) 0))+  assertEqual "annulus hole" (Just RegionExterior) (certifiedPointLocation rings (p 0 0))+  shallow <- requireRight "depth one" (subdivisionBudget 1 4096 4096)+  requireRight "concentric circles within one halving"+    (certifySimpleRegion shallow [CurveComponent (ring True 0 0 2) [ring False 0 0 1]])+    >>= assertEqual "one halving per quarter" [(ContourRef 0 OuterContour, 8), (ContourRef 0 (HoleContour 0), 8)]+      . certifiedPieceCounts+  -- A zero-length connector is a stationary step, contracted at its joint.+  requireRight "zero-length connector"+    (certifySimpleRegion budget [CurveComponent (polygon (p 0 0) [v 4 0, v 0 0, v 0 4, v (-4) 0]) []])+    >>= assertEqual "connector contracted" [(ContourRef 0 OuterContour, 4)] . certifiedPieceCounts++testRefusedRegions :: IO ()+testRefusedRegions = do+  budget <- requireRight "budget" (subdivisionBudget 12 4096 4096)+  let certify = certifySimpleRegion budget+      bowTie = polygon (p 0 0) [v 2 2, v (-2) 0, v 2 (-2)]+      cusp = closedSteps (p 0 0)+        [ curveStep (quadratic (v 1 0)) (v 1 1), curveStep (quadratic (v 0 (-1))) (v 1 (-1))+        , curveStep line (v 0 (-1)), curveStep line (v (-2) 0) ]+  case certify [CurveComponent bowTie []] of+    Left (CertifiedSelfCrossing (ContourSpan _ 0 _ _) (ContourSpan _ 2 _ _) _) -> pure ()+    other -> failWith "bow-tie crossing is certified between its first and third steps" other+  -- Contact at a source step's endpoint is certified with its exact point:+  -- the hole touches the outer circle at (2, 0), a quarter endpoint of both;+  -- a hole circle's quarter endpoint (0, 2) lies inside the square's left+  -- side; a square submitted as its own hole shares all four vertices.+  let outerHole point = Just (Contact (ContourRef 0 OuterContour) (ContourRef 0 (HoleContour 0)) point)+  assertEqual "tangent hole at a shared quarter endpoint" (outerHole (p 2 0))+    (contactAt (certify [CurveComponent (ring True 0 0 2) [ring False 1 0 1]]))+  assertEqual "quarter endpoint inside a straight side" (outerHole (p 0 2))+    (contactAt (certify [CurveComponent square [ring False 1 2 1]]))+  case contactAt (certify [CurveComponent square [square]]) of+    Just (Contact (ContourRef 0 OuterContour) (ContourRef 0 (HoleContour 0)) vertex)+      | vertex `elem` [p 0 0, p 4 0, p 4 4, p 0 4] -> pure ()+    other -> fail ("square as its own hole shares a vertex: " <> show other)+  -- A hole circle touching the outer circle at (3, 4), inside a step of+  -- each: no endpoint is shared, and the tangency stays unresolved.+  case certify [CurveComponent (ring True 0 0 5) [ring False (r 12 5) (r 16 5) 1]] of+    Left (UnresolvedContact (ContourSpan (ContourRef 0 OuterContour) _ _ _) (ContourSpan (ContourRef 0 (HoleContour 0)) _ _ _) DepthExhausted) -> pure ()+    other -> failWith "interior tangency is unresolved contact" other+  case certify [CurveComponent cusp []] of+    Left (UnseparatedJoin (ContourSpan _ 0 _ _) (ContourSpan _ 1 _ _) DepthExhausted) -> pure ()+    other -> failWith "cusp is an unseparated joint" other+  assertEqual "stationary contour" (Just (DegenerateContour (ContourRef 0 OuterContour)))+    (refusal (certify [CurveComponent (polygon (p 0 0) [v 0 0]) []]))+  assertEqual "clockwise outer" (Just (ContourWindingRefused (ContourRef 0 OuterContour) LT))+    (refusal (certify [CurveComponent (ring False 0 0 2) []]))+  assertEqual "counter-clockwise hole"+    (Just (ContourWindingRefused (ContourRef 0 (HoleContour 0)) GT))+    (refusal (certify [CurveComponent (ring True 0 0 2) [ring True 0 0 1]]))+  case certify [CurveComponent (ring True 0 0 2) [], CurveComponent (ring True 3 0 2) []] of+    Left (CertifiedContourCrossing (ContourSpan (ContourRef 0 _) _ _ _) (ContourSpan (ContourRef 1 _) _ _ _) _) -> pure ()+    other -> failWith "overlapping circles cross between components" other++testBudgetRefusals :: IO ()+testBudgetRefusals = do+  few <- requireRight "three leaves" (subdivisionBudget 12 3 4096)+  narrow <- requireRight "two bits" (subdivisionBudget 12 4096 2)+  flat <- requireRight "no depth" (subdivisionBudget 0 4096 4096)+  assertEqual "leaves below the source steps"+    (Just (SourceSpanRefused (ContourSpan (ContourRef 0 OuterContour) 3 unitZero unitOne) LeavesExhausted))+    (refusal (certifySimpleRegion few [CurveComponent square []]))+  assertEqual "bits below the source coordinates"+    (Just (SourceSpanRefused (ContourSpan (ContourRef 0 OuterContour) 0 unitZero unitOne) (BitsExhausted 3)))+    (refusal (certifySimpleRegion narrow [CurveComponent square []]))+  -- The same square's start and relative controls fit four bits wherever it+  -- sits; its located controls do not once it sits at (12, 12), where its+  -- first step ends at (16, 12).+  fourBits <- requireRight "four bits" (subdivisionBudget 12 4096 4)+  requireRight "square at the origin within four bits" (certifySimpleRegion fourBits [CurveComponent square []])+    >>= assertEqual "four sides" [(ContourRef 0 OuterContour, 4)] . certifiedPieceCounts+  assertEqual "located controls beyond the source coordinates"+    (Just (SourceSpanRefused (ContourSpan (ContourRef 0 OuterContour) 0 unitZero unitOne) (BitsExhausted 5)))+    (refusal (certifySimpleRegion fourBits [CurveComponent (polygon (p 12 12) [v 4 0, v 0 4, v (-4) 0]) []]))+  case certifySimpleRegion flat [CurveComponent (ring True 0 0 2) [ring False 0 0 1]] of+    Left (UnresolvedContact _ _ DepthExhausted) -> pure ()+    other -> failWith "a whole-quarter circle needs a halving" other+  assertEqual "invalid budgets" [Left (InvalidBudgetDepth (-1)), Left (InvalidBudgetLeaves 0), Left (InvalidBudgetBits 0)]+    (map (fmap (const ())) [subdivisionBudget (-1) 1 1, subdivisionBudget 0 0 1, subdivisionBudget 0 1 0])++-- The curves nest a small triangle inside the circle of radius 2; lowered at+-- tolerance 2 without subdivision the circle is its chord square, which the+-- triangle lies outside. Both polygons are admitted; their nesting is not the+-- curves'.+testPolygonTopology :: IO ()+testPolygonTopology = do+  budget <- requireRight "budget" (subdivisionBudget 12 4096 4096)+  coarse <- requireRight "chord-square lowering" (loweringPolicy positiveTwo identityAffine2 0 64)+  let triangle = polygon (p (r 13 10) (r 13 10)) [v (r 1 10) 0, v (r (-1) 10) (r 1 10)]+      components = [CurveComponent (ring True 0 0 2) [], CurveComponent triangle []]+  case certifySimpleRegion budget components of+    Right _ -> pure ()+    Left obstruction -> failWith "the curves themselves are certified" (Left obstruction :: Either TopologyObstruction ())+  case lowerSimpleRegion coarse budget components of+    Left (CurveTopologyRefused (PolygonTopologyDiffers (ContourRef 1 OuterContour) (ContourRef 0 OuterContour))) -> pure ()+    other -> failWith "chord square nests otherwise than the circle" (() <$ other)++fine :: IO LoweringPolicy+fine = requireRight "lowering policy" (loweringPolicy positiveOne identityAffine2 20 8192)++square :: Located ClosedTrail+square = polygon (p 0 0) [v 4 0, v 0 4, v (-4) 0]++squareHole :: Located ClosedTrail+squareHole = polygon (p 1 1) [v 0 1, v 1 0, v 0 (-1)]++-- The circle of radius k about (cx, cy) from (cx + k, cy), by four rational+-- quarters, counter-clockwise or clockwise.+ring :: Bool -> ExactRational -> ExactRational -> ExactRational -> Located ClosedTrail+ring counterClockwise cx cy k = closedSteps (p (cx + k) cy) (map quarter quarters)+ where+  quarter (control, end) = curveStep (rationalQuadratic (scale control) positiveOne positiveTwo) (scale end)+  scale (ExactVector x y) = ExactVector (k * x) (k * y)+  quarters+    | counterClockwise = [(v 0 1, v (-1) 1), (v (-1) 0, v (-1) (-1)), (v 0 (-1), v 1 (-1)), (v 1 0, v 1 1)]+    | otherwise = [(v 0 (-1), v (-1) (-1)), (v (-1) 0, v (-1) 1), (v 0 1, v 1 1), (v 1 0, v 1 (-1))]++closedSteps :: ExactPoint -> [CurveStep] -> Located ClosedTrail+closedSteps origin steps = locate origin (closeWith line (openTrail (Seq.fromList steps)))++polygon :: ExactPoint -> [ExactVector] -> Located ClosedTrail+polygon origin = closedSteps origin . map (curveStep line)++-- A certified contact by its two contours and its point.+data Contact = Contact ContourRef ContourRef ExactPoint+  deriving stock (Eq, Show)++contactAt :: Either TopologyObstruction value -> Maybe Contact+contactAt result = case result of+  Left (CertifiedContact (ContourSpan first _ _ _) (ContourSpan second _ _ _) point) -> Just (Contact first second point)+  _ -> Nothing++refusal :: Either obstruction value -> Maybe obstruction+refusal = either Just (const Nothing)++failWith :: Show obstruction => String -> Either obstruction value -> IO ()+failWith label result = fail (label <> ": " <> either show (const "admitted") result)++assert :: String -> Bool -> IO ()+assert label condition = unless condition (fail label)++project :: ExactVector -> ExactPoint -> ExactRational+project (ExactVector ax ay) point = let (x, y) = exactPointCoordinates point in ax * x + ay * y++dot :: ExactVector -> ExactVector -> ExactRational+dot (ExactVector ax ay) (ExactVector bx by) = ax * bx + ay * by++difference :: ExactVector -> ExactVector -> ExactVector+difference (ExactVector ax ay) (ExactVector bx by) = ExactVector (ax - bx) (ay - by)++r :: Integer -> Integer -> ExactRational+r numerator denominator = either (const 0) id (exactRational numerator denominator)++v :: ExactRational -> ExactRational -> ExactVector+v = ExactVector++p :: ExactRational -> ExactRational -> ExactPoint+p = exactPoint

@@ -0,0 +1,198 @@+-- | Regular-frame and fraction-run laws against exact oracles: dyadic speeds+-- normalize exactly, joins are compared with each step's own jet, and every+-- refusal is reached by a concrete source.+module Moonlight.Planar.CurveFrameSpec (tests) where++import Data.Foldable (toList, traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Sequence as Seq+import Moonlight.Planar.Affine (affineColumns, affineIsoMap)+import Moonlight.Planar.Curve+  ( CurveStep, Subpath (..), curveStep, jetStep, line, locate, openTrail, quadratic+  , stepJetFirst )+import Moonlight.Planar.Curve.Authoring (polygonTrail)+import Moonlight.Planar.Curve.Frame+import Moonlight.Planar.Curve.Measure+  ( measurePolicy, measureSubpath, pointAtFraction, radicalPrecision, sampleResidual+  , sampleSite, siteParameter, sitePoint, siteStepIndex, subdivisionBudget )+import Moonlight.Planar.Exact+  ( ExactRational, ExactVector (..), UnitInterval, exactHalf, exactPoint, exactPointCoordinates+  , exactRational, positiveExact, unitHalf, unitInterval, unitIntervalValue, unitOne, unitZero )+import Support (assertEqual, requireRight)++tests :: IO ()+tests = sequence_+  [ testExactSites+  , testRefusals+  , testJoins+  , testNormalization+  , testSampledSites+  , testRuns+  , putStrLn "curve frame: ok"+  ]++policy :: IO FramePolicy+policy = framing 64 40++-- | Precision bits, and the admitted squared-scale deficit @2^-deficit@.+framing :: Int -> Int -> IO FramePolicy+framing bits deficit = do+  precision <- requireRight "precision" (radicalPrecision bits)+  tolerance <- requireRight "tolerance" (positiveExact (exactHalf ^ deficit))+  pure (framePolicy precision tolerance)++open :: [CurveStep] -> Subpath+open = OpenSubpath . locate (exactPoint 1 2) . openTrail . Seq.fromList++exactFrame :: FramePolicy -> Subpath -> Int -> UnitInterval -> IO MeasuredFrame+exactFrame framingPolicy source index parameter = do+  site <- requireRight "exact site" (exactTrailSite source index parameter)+  requireRight "regular frame" (regularFrame framingPolicy (ExactSite site))++frameRefusal :: FramePolicy -> Subpath -> Int -> UnitInterval -> Either FrameError ()+frameRefusal framingPolicy source index parameter =+  exactTrailSite source index parameter >>= fmap (const ()) . regularFrame framingPolicy . ExactSite++columns :: MeasuredFrame -> (ExactVector, ExactVector, ExactVector)+columns = affineColumns . affineIsoMap . measuredFrameIso++-- A speed of four has the dyadic inverse 1/4: the frame is exactly unit.+-- A 3-4-5 tangent normalizes from below within the policy's deficit, and+-- either way the columns are the scaled tangent and its left normal.+testExactSites :: IO ()+testExactSites = do+  framingPolicy <- policy+  upright <- exactFrame framingPolicy (open [curveStep line (ExactVector 0 4)]) 0 unitHalf+  assertEqual "dyadic speed gives an exactly unit frame"+    (ExactVector 0 1, ExactVector (-1) 0, ExactVector 1 4) (columns upright)+  assertEqual "exactly unit squared scale" 1 (measuredFrameScaleSquared upright)+  diagonal <- exactFrame framingPolicy (open [curveStep line (ExactVector 3 4)]) 0 unitHalf+  let (tangent@(ExactVector tx ty), normal, offset) = columns diagonal+      scale = measuredFrameScaleSquared diagonal+  assertEqual "site point is the frame origin" (ExactVector (1 + 3 * exactHalf) 4) offset+  assertEqual "tangent column is parallel to the jet" 0 (cross tangent (ExactVector 3 4))+  assertEqual "normal column is the left normal" (ExactVector (negate ty) tx) normal+  assertEqual "squared scale is the column's squared length" (dot tangent tangent) scale+  assertEqual "squared scale within the deficit, never above one" True+    (scale <= 1 && 1 - scale <= exactHalf ^ (40 :: Int))+  assertEqual "exact site keeps its jet" (ExactVector 3 4) (measuredFrameTangent diagonal)+  site <- requireRight "site" (exactTrailSite (open [curveStep line (ExactVector 3 4)]) 0 unitHalf)+  assertEqual "exact site selection" (0, unitHalf) (siteStepIndex site, siteParameter site)++testRefusals :: IO ()+testRefusals = do+  framingPolicy <- policy+  let single = open [curveStep line (ExactVector 3 4)]+  assertEqual "index beyond the source refused" (Left (SiteStepOutOfRange 1))+    (() <$ exactTrailSite single 1 unitZero)+  assertEqual "negative index refused" (Left (SiteStepOutOfRange (-1)))+    (() <$ exactTrailSite single (-1) unitZero)+  assertEqual "stationary tangent refused" (Left (StationaryFrame 0 unitHalf))+    (frameRefusal framingPolicy (open [curveStep line (ExactVector 0 0)]) 0 unitHalf)+  -- A quadratic whose control coincides with its start is stationary there.+  assertEqual "stationary quadratic start refused" (Left (StationaryFrame 0 unitZero))+    (frameRefusal framingPolicy (open [curveStep (quadratic (ExactVector 0 0)) (ExactVector 4 0)]) 0 unitZero)++-- A join is one point on two steps; the selected side is the step read. A+-- smooth join frames identically from both sides; a corner or a reversal+-- refuses from both; a closed polygon's seam is a join.+testJoins :: IO ()+testJoins = do+  framingPolicy <- policy+  let straight = open [curveStep line (ExactVector 2 0), curveStep line (ExactVector 4 0)]+      corner = open [curveStep line (ExactVector 3 0), curveStep line (ExactVector 0 4)]+      reversal = open [curveStep line (ExactVector 2 0), curveStep line (ExactVector (-4) 0)]+      square = ClosedSubpath (polygonTrail (exactPoint 0 0 :| [exactPoint 4 0, exactPoint 4 4, exactPoint 0 4]))+  before <- exactFrame framingPolicy straight 0 unitOne+  after <- exactFrame framingPolicy straight 1 unitZero+  assertEqual "a smooth join frames alike from either side" (columns before) (columns after)+  assertEqual "the smooth frame is unit along x" (ExactVector 1 0, ExactVector 0 1, ExactVector 3 2) (columns after)+  traverse_ (\(label, source, index, parameter) ->+      assertEqual label (Left (CornerFrame index parameter)) (frameRefusal framingPolicy source index parameter))+    [ ("corner refused before the join", corner, 0, unitOne)+    , ("corner refused after the join", corner, 1, unitZero)+    , ("reversal refused before the join", reversal, 0, unitOne)+    , ("reversal refused after the join", reversal, 1, unitZero)+    , ("closed seam corner refused", square, 0, unitZero)+    , ("closed seam corner refused on the closing step", square, 3, unitOne) ]+  interior <- exactFrame framingPolicy corner 1 unitHalf+  assertEqual "a corner's steps frame away from the join"+    (ExactVector 0 1, ExactVector (-1) 0, ExactVector 4 4) (columns interior)+  site <- requireRight "join site" (exactTrailSite corner 1 unitZero)+  assertEqual "the selected side is the step read" (1, unitZero) (siteStepIndex site, siteParameter site)++-- The inverse speed is enclosed at the policy's precision; a squared scale+-- beneath the admitted deficit is refused rather than returned.+testNormalization :: IO ()+testNormalization = do+  coarse <- framing 1 20+  assertEqual "coarse inverse speed refused" (Left (NormalizationUnresolved 0 unitHalf 0 (exactHalf ^ (20 :: Int))))+    (frameRefusal coarse (open [curveStep line (ExactVector 3 4)]) 0 unitHalf)+  -- With a deficit of one the zero scale would pass the bound, but a zero+  -- frame is singular and is refused all the same.+  permissive <- framing 1 0+  assertEqual "zero scale refused under any deficit" (Left (NormalizationUnresolved 0 unitHalf 0 1))+    (frameRefusal permissive (open [curveStep line (ExactVector 3 4)]) 0 unitHalf)+  fine <- framing 32 20+  accepted <- exactFrame fine (open [curveStep line (ExactVector 3 4)]) 0 unitHalf+  let scale = measuredFrameScaleSquared accepted+  assertEqual "a moderate precision reaches the deficit" True (scale <= 1 && 1 - scale <= exactHalf ^ (20 :: Int))++-- A sampled frame reads the sample's own step at its own parameter.+testSampledSites :: IO ()+testSampledSites = do+  framingPolicy <- policy+  tolerance <- requireRight "tolerance" (positiveExact (exactHalf ^ (10 :: Int)))+  precision <- requireRight "precision" (radicalPrecision 64)+  budget <- requireRight "measure budget" (subdivisionBudget 24 4096 4096)+  let measuring = measurePolicy tolerance precision budget+  let step = curveStep (quadratic (ExactVector 3 8)) (ExactVector 6 0)+  measured <- requireRight "measured" (measureSubpath measuring (open [step]))+  sample <- requireRight "sample" (pointAtFraction unitHalf measured)+  frame <- requireRight "frame" (regularFrame framingPolicy (SampledSite sample))+  let (tangent, _, offset) = columns frame+      jet = stepJetFirst (jetStep (siteParameter (sampleSite sample)) step)+      (px, py) = exactPointCoordinates (sitePoint (sampleSite sample))+  assertEqual "sampled frame reads the step's jet" jet (measuredFrameTangent frame)+  assertEqual "sampled frame points along the jet" True (cross tangent jet == 0 && dot tangent jet > 0)+  assertEqual "sampled frame origin is the sample point" (ExactVector px py) offset+  assertEqual "sampled site keeps its residual" (Just (sampleResidual sample)) (case measuredFrameSite frame of+    SampledSite kept -> Just (sampleResidual kept)+    ExactSite _ -> Nothing)+  assertEqual "single-step sample" 0 (siteStepIndex (sampleSite sample))++testRuns :: IO ()+testRuns = do+  fifth <- exact 1 5 >>= requireRight "fifth" . unitInterval+  fourFifths <- exact 4 5 >>= requireRight "four fifths" . unitInterval+  assertEqual "an empty run refused" (Left (EmptyRun 0)) (() <$ fractionRun 0 fifth fourFifths)+  assertEqual "zero spacing refused" (Left (NonPositiveSpacing fifth fifth))+    (() <$ fractionRun 2 fifth fifth)+  assertEqual "reversed run refused" (Left (NonPositiveSpacing fourFifths fifth))+    (() <$ fractionRun 3 fourFifths fifth)+  single <- requireRight "single" (fractionRun 1 fourFifths fourFifths)+  assertEqual "a single station is its start" [unitIntervalValue fourFifths] (unitIntervalValue <$> toList (runFractions single))+  three <- requireRight "three" (fractionRun 3 fifth fourFifths)+  assertEqual "three evenly spaced stations, ends included" [unitIntervalValue fifth, exactHalf, unitIntervalValue fourFifths]+    (unitIntervalValue <$> toList (runFractions three))+  tolerance <- requireRight "tolerance" (positiveExact (exactHalf ^ (10 :: Int)))+  precision <- requireRight "precision" (radicalPrecision 64)+  budget <- requireRight "measure budget" (subdivisionBudget 24 4096 4096)+  let measuring = measurePolicy tolerance precision budget+  whole <- requireRight "whole" (fractionRun 5 unitZero unitOne)+  square <- requireRight "square" (measureSubpath measuring+    (ClosedSubpath (polygonTrail (exactPoint 0 0 :| [exactPoint 4 0, exactPoint 4 4, exactPoint 0 4]))))+  assertEqual "a closed run holding both ends of the seam refused" (Left RunRepeatsSeam) (() <$ sampleRun whole square)+  segment <- requireRight "segment" (measureSubpath measuring (open [curveStep line (ExactVector 8 0)]))+  samples <- requireRight "open run" (sampleRun whole segment)+  assertEqual "an open run places both ends, in order"+    [exactPoint 1 2, exactPoint 3 2, exactPoint 5 2, exactPoint 7 2, exactPoint 9 2] (sitePoint . sampleSite <$> toList samples)+ where+  exact :: Integer -> Integer -> IO ExactRational+  exact a b = requireRight "exact" (exactRational a b)++cross :: ExactVector -> ExactVector -> ExactRational+cross (ExactVector a b) (ExactVector c d) = a * d - b * c++dot :: ExactVector -> ExactVector -> ExactRational+dot (ExactVector a b) (ExactVector c d) = a * c + b * d

@@ -103,19 +103,20 @@ testRegion :: IO () testRegion = do   policy <- makePolicy 1 identityAffine2 8 100+  budget <- requireRight "topology budget" (subdivisionBudget 8 256 256)   let outer = closed (point 0 0) [vector 4 0, vector 0 4, vector (-4) 0]       hole = closed (point 1 1) [vector 0 1, vector 1 0, vector 0 (-1)]-  (region, receipts) <- requireRight "explicit polygon with hole"-    (lowerSimpleRegion policy [CurveComponent outer [hole]])+  (region, receipts, _) <- requireRight "explicit polygon with hole"+    (lowerSimpleRegion policy budget [CurveComponent outer [hole]])   assertEqual "one receipt per contour" 2 (length receipts)   assertEqual "outer interior" RegionInterior (regionPointLocation region (point 3 3))   assertEqual "hole exterior" RegionExterior     (regionPointLocation region (point (1 + exactHalf) (1 + exactHalf)))   let crossing = closed (point 0 0) [vector 2 2, vector (-2) 0, vector 2 (-2)]   assertRefusal "sampled crossing refuses simple region"-    (lowerSimpleRegion policy [CurveComponent crossing []])+    (lowerSimpleRegion policy budget [CurveComponent crossing []])   assertRefusal "outer winding cannot masquerade as a hole"-    (lowerSimpleRegion policy [CurveComponent outer [outer]])+    (lowerSimpleRegion policy budget [CurveComponent outer [outer]])  testCertificateAdmission :: IO () testCertificateAdmission = do

@@ -0,0 +1,446 @@+-- | Certified arc-length laws against oracles independent of the enclosure+-- kernel: exact integer lengths, exact squaring of irrational ones, a Machin+-- bracket of pi, and a closed-form cusp length. Sampling is never the oracle.+module Moonlight.Planar.CurveMeasureSpec (tests) where++import Data.Foldable (toList, traverse_)+import Data.Ratio (denominator, numerator, (%))+import qualified Data.Sequence as Seq+import Moonlight.Planar.Curve+  ( CurveStep, Located, OpenTrail, Subpath (..), circle, cubic, curveStep, line+  , locate, locatedValue, location, openTrail, quadratic, rationalQuadratic+  , reverseClosedTrail, reverseLocatedTrail )+import Moonlight.Planar.Curve.Measure+import Moonlight.Planar.Exact+  ( ExactPoint, ExactRational, ExactVector (..), exactHalf, exactPoint+  , exactPointCoordinates, exactRational, exactRationalDenominator, exactRationalNumerator+  , positiveExact, positiveOne, positiveTwo, ratioPositive, translateExactPoint, unitHalf+  , unitInterval, unitOne, unitZero )+import Support (assertEqual, requireRight)++tests :: IO ()+tests = sequence_+  [ testPolicies+  , testStraightTrails+  , testStationaryTrails+  , testCircle+  , testCusp+  , testExtremeWeights+  , testBudgets+  , testRanges+  , testBisectionBudget+  , testQueryBudget+  , testSites+  , putStrLn "curve measure: ok"+  ]++testPolicies :: IO ()+testPolicies = do+  tolerance <- exact 1 100 >>= requireRight "tolerance" . positiveExact+  precision <- requireRight "precision" (radicalPrecision 128)+  assertEqual "negative depth refused" (Left (InvalidBudgetDepth (-1))) (() <$ subdivisionBudget (-1) 8 64)+  assertEqual "empty leaf budget refused" (Left (InvalidBudgetLeaves 0)) (() <$ subdivisionBudget 4 0 64)+  assertEqual "empty bit budget refused" (Left (InvalidBudgetBits 0)) (() <$ subdivisionBudget 4 8 0)+  budget <- requireRight "budget" (subdivisionBudget 4 8 64)+  let policy = measurePolicy tolerance precision budget+  assertEqual "policy reads back its parts" (tolerance, precision, budget)+    (measureTolerance policy, measurePrecision policy, measureBudget policy)+  assertEqual "negative distance refused" (Left (NegativeDistance (-1))) (() <$ distance (-1))+  assertEqual "zero distance admitted" (Right 0) (distanceValue <$> distance 0)++testStraightTrails :: IO ()+testStraightTrails = do+  policy <- measuring 1000 24 4096 128 4096+  pythagorean <- measureOpen policy [curveStep line (ExactVector 3 4)]+  assertEqual "a 3-4-5 line has exact length five" (5, 5) (endpoints (lengthBounds pythagorean))++  -- sqrt (1/9 + 1/4) = sqrt 13 / 6, checked by exact squaring.+  third <- exact 1 3+  half <- exact 1 2+  thirteenThirtySixths <- exact 13 36+  irrational <- measureOpen policy [curveStep line (ExactVector third half)]+  let bounds = lengthBounds irrational+  assertEqual "irrational line length is enclosed" True+    (encloses thirteenThirtySixths (lengthEnclosureLower bounds) (lengthEnclosureUpper bounds))+  assertEqual "irrational line width within tolerance" True+    (lengthEnclosureWidth bounds <= toleranceOf 1000)++  let segments = [ExactVector 3 4, ExactVector 6 8]+  unequal <- measureOpen policy (map (curveStep line) segments)+  assertEqual "unequal segments sum exactly" (15, 15) (endpoints (lengthBounds unequal))+  let corner = [ExactVector 4 0, ExactVector 0 3]+  cornered <- measureOpen policy (map (curveStep line) corner)+  assertEqual "a corner sums its legs" (7, 7) (endpoints (lengthBounds cornered))++  start <- sampleAt 0 unequal+  assertEqual "distance zero is the anchor" anchor (sitePoint (sampleSite start))+  checkLinearResidual "distance zero" segments [5, 10] 0 start+  finish <- sampleAt 15 unequal+  assertEqual "the total distance is the end" (exactPoint 11 19) (sitePoint (sampleSite finish))+  assertEqual "the end is exact" 0 (sampleResidual finish)+  middle <- sampleAt 10 unequal+  assertEqual "mid-span sample lies in the second step" 1 (siteStepIndex (sampleSite middle))+  assertEqual "mid-span sample parameter" unitHalf (siteParameter (sampleSite middle))+  assertEqual "mid-span sample point" (exactPoint 8 15) (sitePoint (sampleSite middle))+  checkLinearResidual "mid-span" segments [5, 10] 10 middle+  offCentre <- exact 37 7+  oblique <- sampleAt offCentre unequal+  checkLinearResidual "off-centre" segments [5, 10] offCentre oblique+  atCorner <- sampleAt 4 cornered+  assertEqual "a corner distance is the corner" (exactPoint 6 7) (sitePoint (sampleSite atCorner))+  checkLinearResidual "corner" corner [4, 3] 4 atCorner+  total <- requireRight "total" (distance 16)+  assertEqual "a distance beyond the total is refused"+    (Left (DistanceBeyondTrail 16 (lengthBounds unequal))) (() <$ pointAtLength total unequal)++  reversed <- requireRight "reversed" (measureSubpath policy+    (OpenSubpath (reverseLocatedTrail (locate anchor (openTrail (Seq.fromList (map (curveStep line) corner)))))))+  assertEqual "reversal keeps the length bounds" (lengthBounds cornered) (lengthBounds reversed)++testStationaryTrails :: IO ()+testStationaryTrails = do+  policy <- measuring 1000 24 4096 128 4096+  stationary <- measureOpen policy+    [curveStep line zero, curveStep (cubic zero zero) zero, curveStep (quadratic zero) zero]+  assertEqual "a stationary trail has zero length" (0, 0) (endpoints (lengthBounds stationary))+  still <- sampleAt 0 stationary+  assertEqual "a stationary trail samples its anchor" (anchor, 0) (sitePoint (sampleSite still), sampleResidual still)+  beyond <- requireRight "beyond" (distance 1)+  assertEqual "a stationary trail refuses positive distance"+    (Left (DistanceBeyondTrail 1 (lengthBounds stationary))) (() <$ pointAtLength beyond stationary)+  halfway <- requireRight "halfway" (pointAtFraction unitHalf stationary)+  assertEqual "a stationary fraction is the anchor" anchor (sitePoint (sampleSite halfway))++  padded <- measureOpen policy+    [curveStep line zero, curveStep line (ExactVector 3 4), curveStep line zero]+  assertEqual "stationary spans add nothing" (5, 5) (endpoints (lengthBounds padded))+  arrival <- sampleAt 5 padded+  assertEqual "the full distance reaches the displaced point" (exactPoint 5 11) (sitePoint (sampleSite arrival))++  empty <- requireRight "empty" (measureSubpath policy (OpenSubpath (locate anchor (mempty :: OpenTrail))))+  assertEqual "an empty trail has zero length" (0, 0) (endpoints (lengthBounds empty))+  origin <- requireRight "origin" (distance 0)+  assertEqual "an empty trail has no source span to sample"+    (Left EmptyTrailSample) (() <$ pointAtLength origin empty)++testCircle :: IO ()+testCircle = do+  let (piLow, piHigh) = piBracket+      source = ClosedSubpath (circle positiveTwo)+      west = exactPoint (-2) 0+  fine <- measuring 1000 32 8192 128 8192+  coarse <- measuring 100 32 8192 128 8192+  measured <- requireRight "circle" (measureSubpath fine source)+  rough <- requireRight "coarse circle" (measureSubpath coarse source)+  let bounds = lengthBounds measured+  assertEqual "the measured trail retains its source" source (measuredSource measured)+  assertEqual "circumference 4 pi is enclosed" True+    (rational (lengthEnclosureLower bounds) <= 4 * piLow && 4 * piHigh <= rational (lengthEnclosureUpper bounds))+  assertEqual "circle width within tolerance" True (lengthEnclosureWidth bounds <= toleranceOf 1000)+  assertEqual "summed enclosures stay on the precision's dyadic grid" True+    (all (\value -> (2 ^ (128 :: Int)) `mod` exactRationalDenominator value == 0)+      [lengthEnclosureLower bounds, lengthEnclosureUpper bounds])+  assertEqual "a tighter tolerance nests its bounds" True+    (lengthEnclosureLower (lengthBounds rough) <= lengthEnclosureLower bounds+      && lengthEnclosureUpper bounds <= lengthEnclosureUpper (lengthBounds rough))+  assertEqual "spans are ordered cumulative enclosures" True+    (and (zipWith (\before after -> lengthEnclosureUpper (measuredSpanPrefix before) <= lengthEnclosureUpper (measuredSpanPrefix after))+      (toList (measuredSpans measured)) (drop 1 (toList (measuredSpans measured)))))++  reversed <- requireRight "reversed circle"+    (measureSubpath fine (ClosedSubpath (locate (location (circle positiveTwo))+      (reverseClosedTrail (locatedValue (circle positiveTwo))))))+  assertEqual "reversal keeps the circle's bounds" bounds (lengthBounds reversed)++  -- The half circumference 2 pi ends at (-2, 0); a chord is no longer than+  -- the arc it spans, so the sample's chord to (-2, 0) is bounded by its+  -- residual plus the request's distance from 2 pi.+  halfCircumference <- fromRatio (2 * piLow)+  opposite <- sampleAt halfCircumference measured+  assertEqual "a length sample lies on the circle" 4 (squaredNorm (sitePoint (sampleSite opposite)))+  assertEqual "a length sample is within its residual of the half circumference" True+    (squaredDistance west (sitePoint (sampleSite opposite))+      <= square (rational (sampleResidual opposite) + 2 * (piHigh - piLow)))+  assertEqual "a length residual is within tolerance" True (sampleResidual opposite <= toleranceOf 1000)+  midway <- requireRight "half fraction" (pointAtFraction unitHalf measured)+  assertEqual "a fraction sample lies on the circle" 4 (squaredNorm (sitePoint (sampleSite midway)))+  assertEqual "the half fraction is within its residual of the opposite point" True+    (squaredDistance west (sitePoint (sampleSite midway)) <= square (rational (sampleResidual midway)))+  seam <- requireRight "seam" (pointAtFraction unitZero measured)+  assertEqual "fraction zero is the seam" (exactPoint 2 0) (sitePoint (sampleSite seam))+  lap <- requireRight "lap" (pointAtFraction unitOne measured)+  assertEqual "fraction one closes the lap within its residual" True+    (squaredDistance (exactPoint 2 0) (sitePoint (sampleSite lap)) <= square (rational (sampleResidual lap)))+  quarter <- exact 1 4 >>= requireRight "quarter fraction" . unitInterval+  quarterSample <- requireRight "quarter sample" (pointAtFraction quarter measured)+  assertEqual "the quarter fraction is within its residual of the north point" True+    (squaredDistance (exactPoint 0 2) (sitePoint (sampleSite quarterSample)) <= square (rational (sampleResidual quarterSample)))++testCusp :: IO ()+testCusp = do+  -- x' = 3(1-2t)^2 and y' = 3(1-2t): a cusp at t = 1/2, of length 2 sqrt 2 - 1.+  policy <- measuring 1000 32 8192 128 8192+  measured <- measureOpen policy [curveStep (cubic (ExactVector 1 1) (ExactVector 0 1)) (ExactVector 1 0)]+  let bounds = lengthBounds measured+      shifted value = rational value + 1+  assertEqual "the cusp length 2 sqrt 2 - 1 is enclosed" True+    (square (shifted (lengthEnclosureLower bounds)) <= 8 && 8 <= square (shifted (lengthEnclosureUpper bounds)))+  assertEqual "cusp width within tolerance" True (lengthEnclosureWidth bounds <= toleranceOf 1000)+  cusp <- sampleAt (lengthEnclosureLower bounds * exactHalf) measured+  assertEqual "a cusp sample residual is within tolerance" True (sampleResidual cusp <= toleranceOf 1000)++  -- x = 3t(1-t)(1-2t) on the axis turns at t = (3 -+ sqrt 3)/6, where x is+  -- +-sqrt 3 / 6, so the arc is 2 sqrt 3 / 3 and its square is 4/3. A span+  -- straddling an irrational turning point never meets a purely relative+  -- allowance; the parameter half of the budget accepts it.+  reversing <- measureOpen policy [curveStep (cubic (ExactVector 1 0) (ExactVector (-1) 0)) zero]+  let turning = lengthBounds reversing+  fourThirds <- exact 4 3+  assertEqual "a reversal at irrational parameters is enclosed" True+    (encloses fourThirds (lengthEnclosureLower turning) (lengthEnclosureUpper turning))+  assertEqual "reversal width within tolerance" True (lengthEnclosureWidth turning <= toleranceOf 1000)+  midway <- sampleAt (lengthEnclosureLower turning * exactHalf) reversing+  assertEqual "a reversal sample residual is within tolerance" True (sampleResidual midway <= toleranceOf 1000)++testExtremeWeights :: IO ()+testExtremeWeights = do+  policy <- measuring 1000 64 16384 128 16384+  large <- exact 1000 1 >>= requireRight "large weight" . positiveExact+  huge <- exact 1000000 1 >>= requireRight "huge weight" . positiveExact+  let small = ratioPositive positiveOne large+      control = ExactVector 5 (-3)+      end = ExactVector 2 7+      conic u v = curveStep (rationalQuadratic control u v) end+  traverse_ (\(label, step) -> do+    measured <- measureOpen policy [step]+    reversed <- requireRight label (measureSubpath policy+      (OpenSubpath (reverseLocatedTrail (locate anchor (openTrail (Seq.singleton step))))))+    let bounds = lengthBounds measured+    assertEqual (label <> " width within tolerance") True (lengthEnclosureWidth bounds <= toleranceOf 1000)+    assertEqual (label <> " reversal keeps the bounds") bounds (lengthBounds reversed))+    [ ("weights 1/1000 then 1000", conic small large)+    , ("weights 1000 then 1/1000", conic large small)+    , ("weights 1000 then 10^6", conic large huge)+    ]+  -- Weights (1, k, k^2) reparameterize the polynomial quadratic: one arc,+  -- so the two independently certified enclosures must intersect.+  polynomial <- measureOpen policy [curveStep (quadratic control) end]+  reparameterized <- measureOpen policy [conic large huge]+  let a = lengthBounds polynomial+      b = lengthBounds reparameterized+  assertEqual "a reparameterized conic has the polynomial's length" True+    (max (lengthEnclosureLower a) (lengthEnclosureLower b) <= min (lengthEnclosureUpper a) (lengthEnclosureUpper b))++testBudgets :: IO ()+testBudgets = do+  let source = ClosedSubpath (circle positiveTwo)+  leafy <- measuring 1000 32 4 128 8192+  assertEqual "leaf budget exhaustion refuses" (Just (MeasureBudgetExhausted LeavesExhausted))+    (obligation (measureSubpath leafy source))+  shallow <- measuring 1000 1 8192 128 8192+  assertEqual "depth budget exhaustion refuses" (Just (MeasureBudgetExhausted DepthExhausted))+    (obligation (measureSubpath shallow source))+  narrow <- measuring 1000 32 8192 128 8+  assertEqual "bit budget exhaustion refuses" True+    (case obligation (measureSubpath narrow source) of+      Just (MeasureBudgetExhausted (BitsExhausted width)) -> width > 8+      _ -> False)+  -- At one bit, sqrt 2 is enclosed by [1, 3/2]: the chord and polygon widths+  -- of 1/2 each exceed the span's allowance of (1/200)(1/(3/2) + 1) = 1/120,+  -- while a zero-width comparison of the identical chord and polygon would pass.+  coarse <- measuring 100 32 8192 1 8192+  share <- exact 1 120+  assertEqual "rounding beyond the allowance refuses as precision"+    (Left (SpanRefused 0 unitZero unitOne (PrecisionExhausted 1 share)))+    (() <$ measureSubpath coarse (OpenSubpath (locate anchor (openTrail (Seq.singleton (curveStep line (ExactVector 1 1)))))))++  -- Tiny coordinates do not admit an oversized weight: the source is refused+  -- at the offending step before any length is observed.+  huge <- requireRight "huge weight" (positiveExact (2 ^ (400 :: Int)))+  half <- exact 1 2+  small <- measuring 1000 32 8192 128 64+  let tiny = ExactVector half half+      weighted = OpenSubpath (located+        [curveStep line tiny, curveStep (rationalQuadratic tiny huge positiveOne) tiny])+  assertEqual "an oversized weight refuses before measurement" True+    (case measureSubpath small weighted of+      Left (SpanRefused 1 from to (MeasureBudgetExhausted (BitsExhausted width))) -> (from, to) == (unitZero, unitOne) && width > 64+      _ -> False)+  -- The same budget admits the line at 128 bits of radical precision but not+  -- at 4096, whose dyadic enclosure endpoints alone exceed it.+  let diagonal = OpenSubpath (located [curveStep line (ExactVector 1 1)])+  modest <- measuring 1000 32 8192 128 512+  _ <- requireRight "modest precision" (measureSubpath modest diagonal)+  lavish <- measuring 1000 32 8192 4096 512+  assertEqual "precision beyond the bit budget refuses" True+    (case measureSubpath lavish diagonal of+      Left (SpanRefused 0 from to (MeasureBudgetExhausted (BitsExhausted width))) -> (from, to) == (unitZero, unitOne) && width > 512+      _ -> False)++-- A two-bit budget admits the unit line, the request 1/2 and the halves, but+-- not the quarter parameters; bisecting toward 1/2 refuses the child+-- [1/2, 3/4] before observing it rather than answering with unadmitted bits.+testBisectionBudget :: IO ()+testBisectionBudget = do+  policy <- measuring 4 32 8192 128 2+  measured <- requireRight "unit line" (measureSubpath policy+    (OpenSubpath (locate (exactPoint 0 0) (openTrail (Seq.singleton (curveStep line (ExactVector 1 0)))))))+  half <- exact 1 2+  threeQuarters <- exact 3 4 >>= requireRight "three quarters" . unitInterval+  target <- requireRight "distance" (distance half)+  assertEqual "a bisection child beyond the bit budget refuses"+    (Left (SpanRefused 0 unitHalf threeQuarters (MeasureBudgetExhausted (BitsExhausted 3)))) (() <$ pointAtLength target measured)++-- An exact unit root stays small at 128 bits of precision, so a 16-bit+-- budget admits the line; a request whose own denominator exceeds that+-- budget is refused before any span is consulted.+testQueryBudget :: IO ()+testQueryBudget = do+  policy <- measuring 4 32 8192 128 16+  measured <- requireRight "unit line" (measureSubpath policy+    (OpenSubpath (locate (exactPoint 0 0) (openTrail (Seq.singleton (curveStep line (ExactVector 1 0)))))))+  assertEqual "an exact root at high precision is admitted under a small budget"+    (1, 1) (endpoints (lengthBounds measured))+  target <- exact 1 (2 ^ (1000 :: Int)) >>= requireRight "distance" . distance+  assertEqual "a request beyond the bit budget is refused at admission"+    (Left (RequestRefused (MeasureBudgetExhausted (BitsExhausted 1001)))) (() <$ pointAtLength target measured)++-- The irrational diagonal's rational upper bound lies strictly beyond sqrt 2,+-- so requesting it is undecided, never answered by the trail's end; its lower+-- bound is answered. A fraction reserves its share of the width first.+testRanges :: IO ()+testRanges = do+  policy <- measuring 1000 32 8192 128 4096+  let diagonal = OpenSubpath (located [curveStep line (ExactVector 1 1)])+  measured <- requireRight "diagonal" (measureSubpath policy diagonal)+  let bounds = lengthBounds measured+  assertEqual "the diagonal's enclosure is not exact" True+    (lengthEnclosureLower bounds < lengthEnclosureUpper bounds)+  upper <- requireRight "upper distance" (distance (lengthEnclosureUpper bounds))+  assertEqual "the upper endpoint of an inexact length is unresolved"+    (Left (DistanceUnresolved (lengthEnclosureUpper bounds) bounds)) (() <$ pointAtLength upper measured)+  lower <- sampleAt (lengthEnclosureLower bounds) measured+  assertEqual "the lower endpoint is answered within tolerance" True (sampleResidual lower <= toleranceOf 1000)++  -- Tolerance one at one bit: the enclosure [1, 3/2] leaves a quarter of+  -- uncertainty at the half fraction, reserved before the inverse runs.+  loose <- measuring 1 32 8192 1 4096+  coarse <- requireRight "coarse diagonal" (measureSubpath loose diagonal)+  threeHalves <- exact 3 2+  assertEqual "one bit encloses the diagonal in [1, 3/2]" (1, threeHalves) (endpoints (lengthBounds coarse))+  half <- requireRight "half fraction" (pointAtFraction unitHalf coarse)+  threeQuarters <- exact 3 4+  assertEqual "the inverse runs at 3/4 and the reserve of 1/4 widens it"+    (threeQuarters, unitZero, unitHalf) (sampleResidual half, sampleParameterFrom half, sampleParameterTo half)+  assertEqual "the reserved fraction residual is within tolerance" True (sampleResidual half <= 1)++-- A sample retains its source and names the step it lies on, that step's+-- located start, and its side of any join.+testSites :: IO ()+testSites = do+  policy <- measuring 1000 24 4096 128 4096+  let source = OpenSubpath (located (map (curveStep line) [ExactVector 3 4, ExactVector 6 8]))+  measured <- requireRight "unequal lines" (measureSubpath policy source)+  join <- sampleAt 5 measured+  assertEqual "a sample retains its source" source (siteSource (sampleSite join))+  traverse_ (\value -> sampleAt value measured >>= \sample ->+    assertEqual "every sample's source is its trail's" (measuredSource measured) (siteSource (sampleSite sample)))+    [0, 5, 10, 15]+  assertEqual "the join distance lies after the join"+    (1, AfterJoin, exactPoint 5 11)+    (siteStepIndex (sampleSite join), siteJoinSide (sampleSite join), sitePoint (sampleSite join))+  start <- sampleAt 0 measured+  assertEqual "an open trail's start is away from any join" AwayFromJoin (siteJoinSide (sampleSite start))+  finish <- sampleAt 15 measured+  assertEqual "an open trail's end is away from any join"+    (1, unitOne, AwayFromJoin)+    (siteStepIndex (sampleSite finish), siteParameter (sampleSite finish), siteJoinSide (sampleSite finish))+  lap <- requireRight "circle" (measureSubpath policy (ClosedSubpath (circle positiveTwo)))+  seam <- requireRight "seam" (pointAtFraction unitZero lap)+  assertEqual "a closed trail's seam is a join" (0, AfterJoin) (siteStepIndex (sampleSite seam), siteJoinSide (sampleSite seam))++-- Straight-trail residual law: the arc distance of a point on step @i@ is the+-- rational length before it plus the exact distance from that step's start.+checkLinearResidual :: String -> [ExactVector] -> [ExactRational] -> ExactRational -> ArcSample -> IO ()+checkLinearResidual label segments lengths target sample =+  let index = siteStepIndex (sampleSite sample)+      before = sum (take index lengths)+      stepStart = foldl translateExactPoint anchor (take index segments)+      reach = squaredDistance stepStart (sitePoint (sampleSite sample))+      residual = rational (sampleResidual sample)+      low = rational (target - before) - residual+      high = rational (target - before) + residual+   in do+        assertEqual (label <> " residual within tolerance") True (sampleResidual sample <= toleranceOf 1000)+        assertEqual (label <> " arc distance within residual") True+          ((low <= 0 || square low <= reach) && high >= 0 && reach <= square high)++-- Machin's formula over alternating arctangent series: consecutive partial+-- sums of a series with decreasing terms bracket its limit.+piBracket :: (Rational, Rational)+piBracket = (16 * low5 - 4 * high239, 16 * high5 - 4 * low239)+ where+  (low5, high5) = arctangent (1 % 5)+  (low239, high239) = arctangent (1 % 239)+  arctangent :: Rational -> (Rational, Rational)+  arctangent x =+    let partial n = sum [(-1) ^ k * x ^ (2 * k + 1) / fromInteger (2 * k + 1) | k <- [0 .. n - 1 :: Integer]]+     in (min (partial 12) (partial 13), max (partial 12) (partial 13))++measuring :: Integer -> Int -> Int -> Int -> Int -> IO MeasurePolicy+measuring reciprocal depth leaves bits width = do+  tolerance <- exact 1 reciprocal >>= requireRight "tolerance" . positiveExact+  precision <- requireRight "precision" (radicalPrecision bits)+  budget <- requireRight "measure budget" (subdivisionBudget depth leaves width)+  pure (measurePolicy tolerance precision budget)++measureOpen :: MeasurePolicy -> [CurveStep] -> IO MeasuredTrail+measureOpen policy stepsValue = requireRight "measured trail"+  (measureSubpath policy (OpenSubpath (located stepsValue)))++located :: [CurveStep] -> Located OpenTrail+located = locate anchor . openTrail . Seq.fromList++sampleAt :: ExactRational -> MeasuredTrail -> IO ArcSample+sampleAt value trail = requireRight "distance" (distance value)+  >>= \target -> requireRight "length sample" (pointAtLength target trail)++obligation :: Either MeasureError a -> Maybe MeasureObligation+obligation (Left (SpanRefused _ _ _ refused)) = Just refused+obligation _ = Nothing++endpoints :: LengthEnclosure -> (ExactRational, ExactRational)+endpoints bounds = (lengthEnclosureLower bounds, lengthEnclosureUpper bounds)++encloses :: ExactRational -> ExactRational -> ExactRational -> Bool+encloses squared lower upper = lower <= upper && lower * lower <= squared && squared <= upper * upper++anchor :: ExactPoint+anchor = exactPoint 2 7++zero :: ExactVector+zero = ExactVector 0 0++exact :: Integer -> Integer -> IO ExactRational+exact n d = requireRight "exact rational" (exactRational n d)++fromRatio :: Rational -> IO ExactRational+fromRatio value = exact (numerator value) (denominator value)++toleranceOf :: Integer -> ExactRational+toleranceOf reciprocal = either (const 0) id (exactRational 1 reciprocal)++rational :: ExactRational -> Rational+rational value = exactRationalNumerator value % exactRationalDenominator value++square :: Rational -> Rational+square value = value * value++squaredNorm :: ExactPoint -> ExactRational+squaredNorm point = let (x, y) = exactPointCoordinates point in x * x + y * y++squaredDistance :: ExactPoint -> ExactPoint -> Rational+squaredDistance a b =+  let (ax, ay) = exactPointCoordinates a+      (bx, by) = exactPointCoordinates b+   in square (rational (bx - ax)) + square (rational (by - ay))

@@ -0,0 +1,273 @@+-- | Curve proximity laws against closed-form distances: a decided distance+-- encloses the true one within the tolerance, a violated clearance carries+-- sites on both curves or a crossing certificate, and contact the search+-- cannot reach stays unresolved with the budget it spent. Distance and+-- contact are separate obligations: a tangency's distance is decided while+-- its contact is not.+module Moonlight.Planar.CurveProximitySpec (tests) where++import Control.Monad (unless)+import Data.Foldable (traverse_)+import qualified Data.Sequence as Seq+import Moonlight.Planar.Curve+  ( CurveStep, Subpath (..), circle, curveStep, line, locate, openTrail, quadratic )+import Moonlight.Planar.Curve.Measure+  ( BudgetObligation (..), Distance, LengthEnclosure, MeasurePolicy, TrailSite, distance+  , lengthEnclosureLower, lengthEnclosureUpper, lengthEnclosureWidth, measurePolicy+  , radicalPrecision, siteParameter, sitePoint, subdivisionBudget )+import Moonlight.Planar.Curve.Proximity+import Moonlight.Planar.Exact+  ( ExactPoint, ExactRational, ExactVector (..), exactPoint, exactPointCoordinates, exactRational+  , positiveExact, positiveOne, positiveTwo, unitInterval )+import Support (assertEqual, requireRight)++tests :: IO ()+tests = sequence_+  [ testTangency+  , testSharedPoints+  , testConcentric+  , testCrossing+  , testFarLine+  , testRefusals+  , putStrLn "curve proximity: ok"+  ]++-- The parabola y = x^2 against its tangent at (1/3, 1/9). The contact lies+-- at parameters 2/3 and 1/3, which no halving reaches: the distance is+-- decided within the tolerance, and its lower end is exactly the true+-- distance zero, while clearance at zero stays unresolved at the depth+-- budget, neither holding nor violated.+testTangency :: IO ()+testTangency = do+  policy <- searching 24 20000 4096+  let parabola = open (p (-1) 1) [curveStep (quadratic (v 1 (-2))) (v 2 0)]+      tangent = open (p 0 (r (-1) 9)) [curveStep line (v 1 (r 2 3))]+      onParabola point = let (x, y) = exactPointCoordinates point in y == x * x+      onTangent point = let (x, y) = exactPointCoordinates point in y == r 2 3 * x - r 1 9+  observation <- requireRight "tangent distance" (curveDistance policy parabola tangent)+  let enclosure = distanceBounds observation+      (first, second) = distanceWitness observation+  assertEqual "tangent distance lower end is the contact" 0 (lengthEnclosureLower enclosure)+  assert "tangent distance within the tolerance" (lengthEnclosureWidth enclosure <= r 1 100)+  assert "tangent witness lies on both curves" (onParabola (sitePoint first) && onTangent (sitePoint second))+  assert "tangent witness within the upper end"+    (squaredBetween first second <= lengthEnclosureUpper enclosure * lengthEnclosureUpper enclosure)+  zero <- threshold 0 1+  case clearance policy zero parabola tangent of+    Right (ClearanceUnresolved reached _ DepthExhausted) ->+      assertEqual "unresolved tangency encloses the contact" 0 (lengthEnclosureLower reached)+    other -> failWith "tangent contact is unresolved at the depth budget" other+  hundredth <- threshold 1 100+  case clearance policy hundredth parabola tangent of+    Right (ClearanceViolated (CloserThan a b)) -> do+      assert "closer sites lie on both curves" (onParabola (sitePoint a) && onTangent (sitePoint b))+      assert "closer sites within the threshold" (squaredBetween a b <= r 1 10000)+    other -> failWith "tangent is closer than a hundredth" other++-- An exact common point is a shared point, never a crossing representative:+-- the quarter's endpoint (0, 1) on the chord y = 1 at its parameter 1/3, and+-- a circle against itself.+testSharedPoints :: IO ()+testSharedPoints = do+  policy <- searching 24 20000 4096+  zero <- threshold 0 1+  third <- requireRight "third" (unitInterval (r 1 3))+  let chord = open (p (-1) 1) [curveStep line (v 3 0)]+      unit = ClosedSubpath (circle positiveOne)+  case clearance policy zero unit chord of+    Right (ClearanceViolated (SharedPoint a b)) -> do+      assertEqual "quarter endpoint is the shared point" (p 0 1, p 0 1) (sitePoint a, sitePoint b)+      assertEqual "shared point at the chord's third" third (siteParameter b)+    other -> failWith "quarter endpoint on the chord is shared" other+  case clearance policy zero unit unit of+    Right (ClearanceViolated (SharedPoint a b)) -> assertEqual "circle meets itself" (sitePoint a) (sitePoint b)+    other -> failWith "same circle twice is shared" other+  traverse_+    (\(label, other) -> do+        observation <- requireRight label (curveDistance policy unit other)+        assertEqual label (0, 0) (endpoints (distanceBounds observation)))+    [("quarter endpoint on the chord at distance zero", chord), ("same circle twice at distance zero", unit)]++-- Concentric circles of radii one and two are exactly one apart everywhere:+-- the distance is enclosed within the tolerance, clearance holds below one+-- and, being strict, is violated at one by two sites exactly one apart.+testConcentric :: IO ()+testConcentric = do+  policy <- searching 24 20000 4096+  let inner = ClosedSubpath (circle positiveOne)+      outer = ClosedSubpath (circle positiveTwo)+  observation <- requireRight "concentric distance" (curveDistance policy inner outer)+  let enclosure = distanceBounds observation+  assert "concentric distance encloses one"+    (lengthEnclosureLower enclosure <= 1 && 1 <= lengthEnclosureUpper enclosure)+  assert "concentric distance within the tolerance" (lengthEnclosureWidth enclosure <= r 1 100)+  zero <- threshold 0 1+  below <- threshold 99 100+  one <- threshold 1 1+  traverse_+    (\(label, level) -> case clearance policy level inner outer of+        Right (ClearanceHolds _) -> pure ()+        other -> failWith label other)+    [("concentric circles are disjoint", zero), ("concentric clearance holds below one", below)]+  case clearance policy one inner outer of+    Right (ClearanceViolated (CloserThan a b)) -> assertEqual "concentric sites one apart" 1 (squaredBetween a b)+    other -> failWith "concentric clearance is strict at one" other++-- The unit circle crosses the diagonal y = x at an irrational point: contact+-- is certified by the crossing, with no point claimed.+testCrossing :: IO ()+testCrossing = do+  policy <- searching 24 20000 4096+  zero <- threshold 0 1+  let unit = ClosedSubpath (circle positiveOne)+      diagonal = open (p (-2) (-2)) [curveStep line (v 4 4)]+  case clearance policy zero unit diagonal of+    Right (ClearanceViolated TransversalCrossing {}) -> pure ()+    other -> failWith "circle crosses the diagonal" other+  observation <- requireRight "crossing distance" (curveDistance policy unit diagonal)+  assertEqual "crossing distance lower end is zero" 0 (lengthEnclosureLower (distanceBounds observation))++-- The segment from (5, 5) to (6, 5) is 5 sqrt 2 - 1 from the unit circle,+-- checked by exact squaring of the enclosure's ends.+testFarLine :: IO ()+testFarLine = do+  policy <- searching 24 20000 4096+  let unit = ClosedSubpath (circle positiveOne)+      far = open (p 5 5) [curveStep line (v 1 0)]+  observation <- requireRight "far distance" (curveDistance policy unit far)+  let (lower, upper) = endpoints (distanceBounds observation)+  assert "far distance encloses 5 sqrt 2 - 1" ((lower + 1) * (lower + 1) <= 50 && 50 <= (upper + 1) * (upper + 1))+  assert "far distance within the tolerance" (upper - lower <= r 1 100)+  six <- threshold 6 1+  seven <- threshold 7 1+  case clearance policy six unit far of+    Right (ClearanceHolds _) -> pure ()+    other -> failWith "far segment clears six" other+  case clearance policy seven unit far of+    Right (ClearanceViolated (CloserThan a b)) -> assert "far sites within seven" (squaredBetween a b <= 49)+    other -> failWith "far segment is closer than seven" other++-- Refusals name what ran out: an empty curve; a source step too wide for+-- the bit budget, located controls and so endpoint sites included; a+-- displacement too wide before any enclosure, refused with none; an enclosure or refinement too wide after+-- one, refused with the last admitted; a threshold too wide, on entry; more+-- step pairs than the leaf budget; a leaf budget spent before the+-- tolerance; and a radical precision too coarse for the tolerance.+testRefusals :: IO ()+testRefusals = do+  generous <- searching 24 20000 4096+  let unit = ClosedSubpath (circle positiveOne)+      outer = ClosedSubpath (circle positiveTwo)+      empty = open (p 0 0) []+  assertEqual "empty curve refused" (Left EmptyProximitySource) (() <$ curveDistance generous empty unit)+  narrow <- searching 24 20000 4+  let wide = open (p (r 1 1000) 5) [curveStep line (v 1 0)]+  case curveDistance narrow unit wide of+    Left (ProximitySourceRefused span' (BitsExhausted _)) ->+      assertEqual "wide source step named" (wide, 0) (curveSpanSource span', curveSpanStep span')+    other -> failWith "source wider than the bit budget" (() <$ other)+  -- Two stationary points: both sources fit four bits, their displacement+  -- (30, 30) and its square 1800 do not, before any enclosure exists.+  let upperPoint = open (p 15 15) [curveStep line (v 0 0)]+      lowerPoint = open (p (-15) (-15)) [curveStep line (v 0 0)]+      unenclosed :: Int -> Either ProximityError ()+      unenclosed width = Left (ProximityUnenclosed (ProximityBudgetExhausted (BitsExhausted width)))+  zero <- threshold 0 1+  assertEqual "displacement wider than the bit budget" (unenclosed 11) (() <$ curveDistance narrow upperPoint lowerPoint)+  assertEqual "displacement wider than the bit budget, at clearance" (unenclosed 11) (() <$ clearance narrow zero upperPoint lowerPoint)+  -- A line from (15, 0) by (15, 0): its start and relative controls fit four+  -- bits, its located end (30, 0), the endpoint site, does not, and the span+  -- admission that owns located controls refuses it before any site exists.+  let long = open (p 15 0) [curveStep line (v 15 0)]+      origin = open (p 0 0) [curveStep line (v 0 0)]+      endpointRefused :: Either ProximityError value -> Maybe (Subpath, Int, BudgetObligation)+      endpointRefused result = case result of+        Left (ProximitySourceRefused span' obligation) -> Just (curveSpanSource span', curveSpanStep span', obligation)+        _ -> Nothing+  assertEqual "endpoint site wider than the bit budget" (Just (long, 0, BitsExhausted 5))+    (endpointRefused (curveDistance narrow long origin))+  assertEqual "endpoint site wider than the bit budget, at clearance" (Just (long, 0, BitsExhausted 5))+    (endpointRefused (clearance narrow zero long origin))+  -- The first enclosure, [0, 1], is exact; the next lies on the 2^-64 grid+  -- of the radical precision, wider than four bits, so the refusal carries+  -- the last enclosure admitted.+  case curveDistance narrow unit outer of+    Left (ProximityRefused (ProximityBudgetExhausted (BitsExhausted 65)) reached _) ->+      assertEqual "last admitted enclosure" (0, 1) (lengthEnclosureLower reached, lengthEnclosureUpper reached)+    other -> failWith "enclosure wider than the bit budget" (() <$ other)+  coarseNarrow <- policyWith 1 24 20000 4+  case curveDistance coarseNarrow unit outer of+    Left (ProximityRefused (ProximityBudgetExhausted (BitsExhausted width)) reached _) -> do+      assert "refinement wider than four bits" (width > 4)+      assert "refused refinement still encloses one" (lengthEnclosureLower reached <= 1 && 1 <= lengthEnclosureUpper reached)+    other -> failWith "refinement wider than the bit budget" (() <$ other)+  -- A threshold of 2^-1000 is refused on entry, before it is squared or+  -- compared; at zero the same policy decides.+  sixteen <- policyWith 1 24 20000 16+  tiny <- threshold 1 (2 ^ (1000 :: Int))+  let far = open (p 5 5) [curveStep line (v 1 0)]+  assertEqual "threshold wider than the bit budget"+    (Left (ProximityRequestRefused (ProximityBudgetExhausted (BitsExhausted 1001)))) (() <$ clearance sixteen tiny unit far)+  case clearance sixteen zero unit far of+    Right (ClearanceHolds _) -> pure ()+    other -> failWith "the same policy decides at zero" other+  few <- searching 24 8 4096+  assertEqual "step pairs beyond the leaf budget" (Left (ProximityStepPairsRefused 4 4)) (() <$ curveDistance few unit outer)+  -- Ten billion step pairs are refused from the two step counts: building or+  -- enumerating them would not finish in the suite's time.+  let rail offset = open (p 0 offset) (replicate 100000 (curveStep line (v 1 0)))+  assertEqual "step pairs decided from the counts" (Left (ProximityStepPairsRefused 100000 100000))+    (() <$ curveDistance generous (rail 0) (rail 1))+  assertEqual "step pairs decided from the counts, at clearance" (Left (ProximityStepPairsRefused 100000 100000))+    (() <$ clearance generous zero (rail 0) (rail 1))+  spent <- searching 24 20 4096+  case curveDistance spent unit outer of+    Left (ProximityRefused (ProximityBudgetExhausted LeavesExhausted) reached candidates) -> do+      assert "exhausted distance still encloses one" (lengthEnclosureLower reached <= 1 && 1 <= lengthEnclosureUpper reached)+      assert "exhausted distance reports its candidates" (not (Seq.null candidates))+    other -> failWith "leaf budget spent before the tolerance" (() <$ other)+  coarse <- policyWith 1 24 20000 4096+  case curveDistance coarse unit outer of+    Left (ProximityRefused (ProximityPrecisionExhausted rounding tolerance) _ _) ->+      assert "rounding exceeds the tolerance" (rounding > tolerance)+    other -> failWith "precision too coarse for the tolerance" (() <$ other)++searching :: Int -> Int -> Int -> IO MeasurePolicy+searching = policyWith 64++policyWith :: Int -> Int -> Int -> Int -> IO MeasurePolicy+policyWith bits depth leaves width = do+  tolerance <- requireRight "tolerance" (positiveExact (r 1 100))+  precision <- requireRight "precision" (radicalPrecision bits)+  budget <- requireRight "proximity budget" (subdivisionBudget depth leaves width)+  pure (measurePolicy tolerance precision budget)++threshold :: Integer -> Integer -> IO Distance+threshold numerator denominator = requireRight "threshold" (distance (r numerator denominator))++open :: ExactPoint -> [CurveStep] -> Subpath+open origin steps = OpenSubpath (locate origin (openTrail (Seq.fromList steps)))++squaredBetween :: TrailSite -> TrailSite -> ExactRational+squaredBetween a b =+  let (ax, ay) = exactPointCoordinates (sitePoint a)+      (bx, by) = exactPointCoordinates (sitePoint b)+   in (bx - ax) * (bx - ax) + (by - ay) * (by - ay)++endpoints :: LengthEnclosure -> (ExactRational, ExactRational)+endpoints enclosure = (lengthEnclosureLower enclosure, lengthEnclosureUpper enclosure)++failWith :: Show value => String -> value -> IO ()+failWith label value = fail (label <> ": " <> show value)++assert :: String -> Bool -> IO ()+assert label condition = unless condition (fail label)++r :: Integer -> Integer -> ExactRational+r numerator denominator = either (const 0) id (exactRational numerator denominator)++v :: ExactRational -> ExactRational -> ExactVector+v = ExactVector++p :: ExactRational -> ExactRational -> ExactPoint+p = exactPoint

@@ -0,0 +1,118 @@+-- | Source-span provenance laws: a selected site is its step's exact point,+-- the one measurement reaches by subdivision; a join's neighbour wraps at a+-- closed seam; unit parameters are subdivided and spaced exactly.+module Moonlight.Planar.CurveSourceSpec (tests) where++import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Sequence as Seq+import Moonlight.Planar.Curve+  ( Subpath (..), circle, cubic, curveStep, evaluateStep, line, locate, openTrail, quadratic+  , rationalQuadratic )+import Moonlight.Planar.Curve.Measure+  ( JoinSide (..), MeasuredTrail, measurePolicy, measureSubpath, pointAtFraction, subdivisionBudget+  , radicalPrecision, sampleSite )+import Moonlight.Planar.Exact+  ( ExactPoint, ExactRational, ExactVector (..), UnitInterval, exactPoint, exactRational, positiveExact+  , positiveTwo, translateExactPoint, unitInterval, unitOne, unitZero )+import Moonlight.Planar.Internal.CurveSource+  ( TrailSite, joinNeighbourJet, selectSite, siteJet, siteJoinSide, siteParameter, sitePoint+  , siteSource, siteStep, siteStepIndex, sourceStepCurve, sourceStepStart, sourceSteps )+import Moonlight.Planar.Internal.ExactRational (unitIntervalRun, unitMidpoint)+import Support (assertEqual, requireJust, requireRight)++tests :: IO ()+tests = sequence_+  [ testSelectedSites+  , testJoinNeighbours+  , testUnitParameters+  , putStrLn "curve source: ok"+  ]++-- A site selected at a measured sample's step and parameter is the sample's+-- site, point and join side included: evaluation and the measurement's exact+-- subdivision agree, which is the point law 'trailSite' leaves to its callers.+testSelectedSites :: IO ()+testSelectedSites = do+  tolerance <- exact 1 1000 >>= requireRight "tolerance" . positiveExact+  precision <- requireRight "precision" (radicalPrecision 128)+  budget <- requireRight "budget" (subdivisionBudget 24 4096 4096)+  let policy = measurePolicy tolerance precision budget+  weight <- exact 3 2 >>= requireRight "weight" . positiveExact+  let mixed = OpenSubpath (locate (exactPoint 2 7) (openTrail (Seq.fromList+        [ curveStep (quadratic (ExactVector 1 3)) (ExactVector 4 1)+        , curveStep (cubic (ExactVector 1 (-2)) (ExactVector 3 2)) (ExactVector 5 0)+        , curveStep (rationalQuadratic (ExactVector 2 2) weight positiveTwo) (ExactVector 3 (-1))+        , curveStep line (ExactVector 0 2)+        ])))+      lap = ClosedSubpath (circle positiveTwo)+  fractions <- traverse (uncurry unit) [(0, 1), (1, 7), (1, 3), (1, 2), (5, 6), (1, 1)]+  traverse_ (\source -> do+    measured <- requireRight "measured source" (measureSubpath policy source)+    traverse_ (sampleAgrees measured) fractions)+    [mixed, lap]++sampleAgrees :: MeasuredTrail -> UnitInterval -> IO ()+sampleAgrees measured fraction = do+  site <- sampleSite <$> requireRight "fraction sample" (pointAtFraction fraction measured)+  selected <- requireJust "selected site"+    (selectSite (siteSource site) (siteStepIndex site) (siteParameter site))+  assertEqual "a selected site is the measured sample's site" site selected+  assertEqual "a measured site is its step's exact point" (evaluatedPoint site) (sitePoint site)++-- The point law 'trailSite' leaves to its callers: a site's point is its+-- step's located start translated by the step's value at its parameter.+evaluatedPoint :: TrailSite -> ExactPoint+evaluatedPoint site =+  translateExactPoint (sourceStepStart step) (evaluateStep (siteParameter site) (sourceStepCurve step))+ where+  step = siteStep site++testJoinNeighbours :: IO ()+testJoinNeighbours = do+  let lap = ClosedSubpath (circle positiveTwo)+      final = Seq.length (sourceSteps lap) - 1+  seamEnd <- requireJust "seam end" (selectSite lap final unitOne)+  seamStart <- requireJust "seam start" (selectSite lap 0 unitZero)+  assertEqual "a closed trail's last step ends before its seam" BeforeJoin (siteJoinSide seamEnd)+  assertEqual "a closed trail's first step starts after its seam" AfterJoin (siteJoinSide seamStart)+  assertEqual "before the seam, the neighbour is the first step's start"+    (Just (siteJet seamStart)) (joinNeighbourJet seamEnd)+  assertEqual "after the seam, the neighbour is the last step's end"+    (Just (siteJet seamEnd)) (joinNeighbourJet seamStart)++  let open = OpenSubpath (locate (exactPoint 2 7) (openTrail (Seq.fromList+        [curveStep line (ExactVector 3 4), curveStep line (ExactVector 6 8)])))+  start <- requireJust "open start" (selectSite open 0 unitZero)+  finish <- requireJust "open end" (selectSite open 1 unitOne)+  beforeJoin <- requireJust "before the join" (selectSite open 0 unitOne)+  afterJoin <- requireJust "after the join" (selectSite open 1 unitZero)+  assertEqual "an open trail's ends have no neighbour"+    (Nothing, Nothing) (joinNeighbourJet start, joinNeighbourJet finish)+  assertEqual "the step after the join starts at the join" (exactPoint 5 11) (sourceStepStart (siteStep afterJoin))+  assertEqual "an open join's neighbours are the adjacent steps"+    (Just (siteJet afterJoin), Just (siteJet beforeJoin))+    (joinNeighbourJet beforeJoin, joinNeighbourJet afterJoin)+  assertEqual "a missing step selects no site"+    (Nothing, Nothing) (selectSite open 2 unitZero, selectSite open (-1) unitZero)++testUnitParameters :: IO ()+testUnitParameters = do+  fifth <- unit 1 5+  fourFifths <- unit 4 5+  half <- unit 1 2+  third <- unit 1 3+  fiveTwelfths <- unit 5 12+  assertEqual "two intervals are three points, both ends included"+    (fifth :| [half, fourFifths]) (unitIntervalRun 2 fifth fourFifths)+  assertEqual "zero intervals are the first point alone" (fifth :| []) (unitIntervalRun 0 fifth fourFifths)+  assertEqual "one interval is its two ends" (fifth :| [fourFifths]) (unitIntervalRun 1 fifth fourFifths)+  assertEqual "a run may descend" (fourFifths :| [half, fifth]) (unitIntervalRun 2 fourFifths fifth)+  assertEqual "the midpoint is exact" fiveTwelfths (unitMidpoint third half)+  assertEqual "the midpoint of the ends is one half" half (unitMidpoint unitZero unitOne)++unit :: Integer -> Integer -> IO UnitInterval+unit n d = exact n d >>= requireRight "unit parameter" . unitInterval++exact :: Integer -> Integer -> IO ExactRational+exact n d = requireRight "exact rational" (exactRational n d)

@@ -1,15 +1,16 @@ -- | Exact laws of the authored curve algebra, independently of flattening. module Moonlight.Planar.CurveSpec (tests) where +import Control.Monad (when) import Data.Foldable (toList, traverse_) import qualified Data.Sequence as Seq import Moonlight.Planar.Affine-  ( affine2, composeAffine2, identityAffine2, transformPoint, transformVector )+  ( Affine2, affine2, composeAffine2, identityAffine2, transformPoint, transformVector ) import Moonlight.Planar.Curve import Moonlight.Planar.Exact-  ( ExactVector (..), ScalarRefinementError (..), UnitInterval+  ( ExactRational, ExactVector (..), ScalarRefinementError (..), UnitInterval   , addExactVectors, blendPositive, divideByPositive, exactHalf, exactPoint-  , exactPointCoordinates, exactRational, positiveExact, positiveExactValue+  , exactPointCoordinates, exactRational, exactThird, positiveExact, positiveExactValue   , positiveOne, positiveSumSquares, positiveTwo, ratioPositive   , translateExactPoint, unitHalf, unitInterval, unitIntervalValue, unitOne, unitZero   )@@ -23,6 +24,10 @@   , testCircles   , testJets   , testAffineActions+  , testSubdivision+  , testRestriction+  , testStepJets+  , testRationalJetOracles   , putStrLn "curve: ok"   ] @@ -74,7 +79,7 @@     assertEqual "evaluation starts at zero" zero (evaluateStep unitZero step)     assertEqual "evaluation ends at displacement" (curveStepEnd step) (evaluateStep unitOne step)     assertEqual "reversal involution" step (reverseStep (reverseStep step))-    let (left, right) = splitStepHalf step+    let (left, right) = splitStep unitHalf step     assertEqual "split endpoint" (evaluateStep unitHalf step) (curveStepEnd left)     assertEqual "split displacement"       (curveStepEnd step) (addExactVectors (curveStepEnd left) (curveStepEnd right))@@ -179,17 +184,224 @@     (trailDisplacement (openTrail (closedTrailSteps (transformClosedTrail b closed))))   traverse_ (\step -> do     let transformed = transformStep a step-        (left,right) = splitStepHalf step     assertEqual "relative step ignores translation" step (transformStep translation step)-    assertEqual "subdivision commutes with affine action"-      (transformStep a left, transformStep a right)-      (splitStepHalf transformed)     traverse_ (\t -> do+      let (left, right) = splitStep t step+      assertEqual "subdivision commutes with affine action"+        (transformStep a left, transformStep a right)+        (splitStep t transformed)       assertEqual "evaluation commutes with affine action"         (transformVector a (evaluateStep t step)) (evaluateStep t transformed)       assertEqual "point and vector actions agree at every placed sample"         (transformPoint a (translateExactPoint anchor (evaluateStep t step)))         (translateExactPoint (transformPoint a anchor) (evaluateStep t transformed))) ts) steps++-- | The shared fixtures plus positive weights at both extremes in both+-- positions, and curves collapsed to a point or onto a segment.+lawSteps :: IO [CurveStep]+lawSteps = do+  large <- requireRight "large weight" (positiveExact 1000)+  let small = ratioPositive positiveOne large+      extreme u v = curveStep (rationalQuadratic (ExactVector 5 (-3)) u v) (ExactVector 2 7)+  pure (steps <>+    [ extreme small large+    , extreme large small+    , extreme small small+    , extreme large large+    , curveStep (quadratic zero) zero+    , curveStep (cubic zero zero) zero+    , curveStep (rationalQuadratic zero large small) zero+    , curveStep (cubic (ExactVector 1 2) (ExactVector 2 4)) (ExactVector 3 6)+    , curveStep (rationalQuadratic (ExactVector 1 1) small large) (ExactVector 3 3)+    ])++testSubdivision :: IO ()+testSubdivision = do+  ts <- parameters+  fixtures <- lawSteps+  traverse_ (\step -> traverse_ (checkSplit ts step) ts) fixtures+ where+  checkSplit :: [UnitInterval] -> CurveStep -> UnitInterval -> IO ()+  checkSplit ts step t = do+    let (left, right) = splitStep t step+        s = unitIntervalValue t+    assertEqual "split point" (evaluateStep t step) (curveStepEnd left)+    assertEqual "split displacement"+      (curveStepEnd step) (addExactVectors (curveStepEnd left) (curveStepEnd right))+    traverse_ (\u -> do+      let w = unitIntervalValue u+      inner <- unit "left source parameter" (s * w)+      outer <- unit "right source parameter" (s + (1 - s) * w)+      let innerJet = jetStep inner step+          outerJet = jetStep outer step+          leftJet = jetStep u left+          rightJet = jetStep u right+      assertEqual "left split parameterization" (evaluateStep inner step) (evaluateStep u left)+      assertEqual "right split parameterization" (evaluateStep outer step)+        (addExactVectors (curveStepEnd left) (evaluateStep u right))+      assertEqual "left first derivative chain factor"+        (scale s (stepJetFirst innerJet)) (stepJetFirst leftJet)+      assertEqual "left second derivative chain factor"+        (scale (s * s) (stepJetSecond innerJet)) (stepJetSecond leftJet)+      assertEqual "right first derivative chain factor"+        (scale (1 - s) (stepJetFirst outerJet)) (stepJetFirst rightJet)+      assertEqual "right second derivative chain factor"+        (scale ((1 - s) * (1 - s)) (stepJetSecond outerJet)) (stepJetSecond rightJet)) ts++testRestriction :: IO ()+testRestriction = do+  ts <- parameters+  fixtures <- lawSteps+  third <- unit "third" exactThird+  full <- requireRight "full span" (parameterSpan unitZero unitOne)+  assertEqual "reversed span refused"+    (Left (ReversedParameterSpan unitHalf third)) (parameterSpan unitHalf third)+  traverse_ (\step -> do+    let located = locate anchor step+    assertEqual "full-span restriction is the located step" located (restrictStep full located)+    traverse_ (\from -> traverse_ (checkSpan ts located from) ts) ts) fixtures+ where+  anchor = exactPoint 2 7+  checkSpan :: [UnitInterval] -> Located CurveStep -> UnitInterval -> UnitInterval -> IO ()+  checkSpan ts located from to+    | from > to = assertEqual "reversed span refused"+        (Left (ReversedParameterSpan from to)) (parameterSpan from to)+    | otherwise = do+        range <- requireRight "ordered span" (parameterSpan from to)+        let restricted = restrictStep range located+            step = locatedValue located+            local = locatedValue restricted+            start = unitIntervalValue from+            width = unitIntervalValue to - start+            place = translateExactPoint (location located)+            placeLocal = translateExactPoint (location restricted)+        assertEqual "span retains its endpoints"+          (from, to) (parameterSpanFrom range, parameterSpanTo range)+        assertEqual "restriction is anchored at the source point"+          (place (evaluateStep from step)) (location restricted)+        when (from == to) $+          assertEqual "equal-endpoint restriction is stationary"+            True (all (== zero) (stepControlPoints local))+        traverse_ (\u -> do+          source <- unit "restricted source parameter" (start + width * unitIntervalValue u)+          let sourceJet = jetStep source step+              localJet = jetStep u local+          assertEqual "restriction parameterization"+            (place (evaluateStep source step)) (placeLocal (evaluateStep u local))+          assertEqual "restriction first derivative chain factor"+            (scale width (stepJetFirst sourceJet)) (stepJetFirst localJet)+          assertEqual "restriction second derivative chain factor"+            (scale (width * width) (stepJetSecond sourceJet)) (stepJetSecond localJet)) ts++testStepJets :: IO ()+testStepJets = do+  ts <- parameters+  fixtures <- lawSteps+  assertEqual "stationary step has a zero jet"+    (zero, zero, zero) (jetParts (jetStep unitHalf (curveStep line zero)))+  traverse_ (\step -> do+    assertEqual "start jet is the jet at zero" (startJet step) (stepJetFirst (jetStep unitZero step))+    assertEqual "end jet is the jet at one" (endJet step) (stepJetFirst (jetStep unitOne step))+    traverse_ (checkJet ts step) ts) fixtures+ where+  placements =+    [ affine2 (ExactVector (-2) 1) (ExactVector 3 4) (ExactVector 8 5)+    , affine2 (ExactVector 1 2) (ExactVector 2 4) (ExactVector (-3) 2)+    ]+  checkJet :: [UnitInterval] -> CurveStep -> UnitInterval -> IO ()+  checkJet ts step u = do+    let jet = jetStep u step+        w = unitIntervalValue u+    mirrored <- unit "mirrored parameter" (1 - w)+    let mirror = jetStep mirrored step+        reversed = jetStep u (reverseStep step)+    assertEqual "jet value is evaluation" (evaluateStep u step) (stepJetValue jet)+    assertEqual "reversed jet value"+      (stepJetValue mirror) (addExactVectors (curveStepEnd step) (stepJetValue reversed))+    assertEqual "reversed first derivative" (scale (-1) (stepJetFirst mirror)) (stepJetFirst reversed)+    assertEqual "reversed second derivative" (stepJetSecond mirror) (stepJetSecond reversed)+    traverse_ (\placement -> assertEqual "jet commutes with the affine linear part"+      (mapJet placement jet) (jetParts (jetStep u (transformStep placement step)))) placements+    -- Independent of the Bernstein difference forms: a polynomial's Taylor+    -- series terminates, so evaluation elsewhere is exactly recovered.+    traverse_ (\third -> traverse_ (\v -> do+      let h = unitIntervalValue v - w+      assertEqual "polynomial Taylor expansion terminates" (evaluateStep v step)+        (addExactVectors (stepJetValue jet)+          (addExactVectors (scale h (stepJetFirst jet))+            (addExactVectors (scale (h * h * exactHalf) (stepJetSecond jet))+              (scale (h * h * h * exactHalf * exactThird) third))))) ts)+      (polynomialThirdDerivative step)++polynomialThirdDerivative :: CurveStep -> Maybe ExactVector+polynomialThirdDerivative step = case shapeView (curveStepShape step) of+  LinearView -> Just zero+  QuadraticView _ -> Just zero+  CubicView a b ->+    Just (scale 6 (addExactVectors (curveStepEnd step) (scale 3 (addExactVectors a (scale (-1) b)))))+  RationalQuadraticView {} -> Nothing++-- | Rational derivatives against oracles that share none of the quotient+-- arithmetic: the circle's constant radius, and the numerator and weight+-- polynomials differentiated independently in the power basis.+testRationalJetOracles :: IO ()+testRationalJetOracles = do+  ts <- parameters+  fixtures <- lawSteps+  let located = circle positiveTwo+      segments = toList (closedTrailSteps (locatedValue located))+      anchors = scanl (\anchor step -> translateExactPoint anchor (curveStepEnd step))+        (location located) segments+  traverse_ (\(anchor, step) -> traverse_ (checkCircle anchor step) ts) (zip anchors segments)+  traverse_ (\step -> traverse_ (checkQuotient step) ts) (fixtures <> segments)+ where+  checkCircle anchor step t = do+    let jet = jetStep t step+        (x, y) = exactPointCoordinates (translateExactPoint anchor (stepJetValue jet))+        radius = ExactVector x y+        first = stepJetFirst jet+    assertEqual "circle velocity is tangent" 0 (dot radius first)+    assertEqual "circle second-order radius law" 0 (dot first first + dot radius (stepJetSecond jet))+  checkQuotient step parameter = case shapeView (curveStepShape step) of+    RationalQuadraticView control u v -> do+      let t = unitIntervalValue parameter+          s = 1 - t+          a = positiveExactValue u+          b = positiveExactValue v+          e = curveStepEnd step+          jet = jetStep parameter step+          value = stepJetValue jet+          first = stepJetFirst jet+          w0 = s * s + 2 * a * t * s + b * t * t+          w1 = 2 * a * (1 - 2 * t) - 2 * s + 2 * b * t+          w2 = 2 - 4 * a + 2 * b+          n0 = addExactVectors (scale (2 * a * t * s) control) (scale (b * t * t) e)+          n1 = addExactVectors (scale (2 * a * (1 - 2 * t)) control) (scale (2 * b * t) e)+          n2 = addExactVectors (scale (-4 * a) control) (scale (2 * b) e)+      assertEqual "rational numerator is weight times value" n0 (scale w0 value)+      assertEqual "rational first quotient rule" n1+        (addExactVectors (scale w1 value) (scale w0 first))+      assertEqual "rational second quotient rule" n2+        (addExactVectors (scale w2 value)+          (addExactVectors (scale (2 * w1) first) (scale w0 (stepJetSecond jet))))+    _ -> pure ()++unit :: String -> ExactRational -> IO UnitInterval+unit label = requireRight label . unitInterval++scale :: ExactRational -> ExactVector -> ExactVector+scale s (ExactVector x y) = ExactVector (s * x) (s * y)++dot :: ExactVector -> ExactVector -> ExactRational+dot (ExactVector ax ay) (ExactVector bx by) = ax * bx + ay * by++jetParts :: StepJet -> (ExactVector, ExactVector, ExactVector)+jetParts jet = (stepJetValue jet, stepJetFirst jet, stepJetSecond jet)++mapJet :: Affine2 -> StepJet -> (ExactVector, ExactVector, ExactVector)+mapJet placement jet =+  let (value, first, second) = jetParts jet+   in (transformVector placement value, transformVector placement first, transformVector placement second)  zero :: ExactVector zero = ExactVector 0 0

@@ -6,9 +6,15 @@ import Data.List (isInfixOf) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Sequence as Seq-import Moonlight.Planar.Curve (Path, Subpath (..), location, path, transformPath)+import Moonlight.Planar.Affine+  ( AffineIso2, affine2, affineColumns, affineIso2, affineIsoMap, composeAffineIso2+  , inverseAffineIso2, transformPoint )+import Moonlight.Planar.Curve+  ( Located, OpenTrail, Path, Subpath (..), curveStepEnd, locatedValue, location, path+  , startJet, trailSteps, transformPath ) import Moonlight.Planar.Exact-  ( exactHalf, exactPoint, positiveExact, unitOne, unitZero )+  ( ExactPoint, ExactRational, ExactVector (..), exactHalf, exactPoint, exactPointCoordinates+  , positiveExact, translateExactPoint, unitOne, unitZero ) import Moonlight.Planar.Exhibit.EquationalGarden   ( GardenControls (..), GardenPart (..), defaultGardenControls, gardenPartName   , gardenPicture, leafOutline, petalOutline, gardenPlants, GardenPlant (..)@@ -27,6 +33,19 @@   wind <- either (fail . show) pure (gardenPicture defaultGardenControls { gardenBreeze = unitOne })   traverse_ checkAttachments [defaultGardenControls,     defaultGardenControls { blossomOpening = unitOne, gardenBreeze = unitOne }]+  stillAir <- either (fail . show) pure (gardenPlants defaultGardenControls { gardenBreeze = unitZero })+  breeze <- either (fail . show) pure (gardenPlants defaultGardenControls)+  gale <- either (fail . show) pure (gardenPlants defaultGardenControls { gardenBreeze = unitOne })+  openedPlants <- either (fail . show) pure (gardenPlants defaultGardenControls { blossomOpening = unitOne })+  traverse_ socketsOnStem (stillAir <> breeze <> gale)+  traverse_ leanFollowsTangent (zip3 stillAir breeze gale)+  check "breeze leaves every blossom frame fixed"+    (all (\(a, b) -> blossomFrames a == blossomFrames b) (zip stillAir gale))+  check "opening leaves every stem trail and stem socket fixed"+    (all (\(a, b) -> gardenStemTrail a == gardenStemTrail b && stemFrames a == stemFrames b) (zip breeze openedPlants))+  check "breeze moves every leaf socket"+    (all (\(a, b) -> motifPort (gardenStem a) LowerLeafSocket /= motifPort (gardenStem b) LowerLeafSocket+      && motifPort (gardenStem a) UpperLeafSocket /= motifPort (gardenStem b) UpperLeafSocket) (zip stillAir gale))   traverse_ (checkLayer baseline opened [Blossoms]) parts   traverse_ (checkLayer baseline wind [Stems, Leaves]) parts   check "petal width edit changes the real contour"@@ -58,6 +77,68 @@       (motifPort (gardenUpperLeaf plant) LeafRoot == motifPort (gardenStem plant) UpperLeafSocket)     check "blossom matches its full stem socket frame"       (motifPort (gardenBlossom plant) BlossomRoot == motifPort (gardenStem plant) BlossomSocket)) assemblies++-- The sockets read the painted trail: each leaf origin is a knot, the start+-- of step one or two, and the blossom origin is the trail's end. The knots+-- are recomputed here from the trail's own step displacements.+socketsOnStem :: GardenPlant -> IO ()+socketsOnStem plant = do+  let knots = stemKnots (gardenStemTrail plant)+      origin port = transformPoint (affineIsoMap (motifPort (gardenStem plant) port)) (exactPoint 0 0)+  check "stem has root, two leaf knots and the flower" (length knots == 4)+  check "lower leaf socket sits on its knot" (Just (origin LowerLeafSocket) == lookupIndex 1 knots)+  check "upper leaf socket sits on its knot" (Just (origin UpperLeafSocket) == lookupIndex 2 knots)+  check "blossom socket sits on the stem's end" (Just (origin BlossomSocket) == lookupIndex 3 knots)++-- Breeze turns a leaf socket only through the stem's tangent at its knot.+-- Undoing the exact, unnormalized tangent frame there (tangent, left normal)+-- leaves the authored lean and size, scaled by the positive normalization+-- factor: across breezes those relative matrices are positive multiples of+-- one another, and their origin is the knot itself.+leanFollowsTangent :: (GardenPlant, GardenPlant, GardenPlant) -> IO ()+leanFollowsTangent (still, middle, strong) = traverse_ relation [(LowerLeafSocket, 1), (UpperLeafSocket, 2)]+ where+  relation :: (StemPort, Int) -> IO ()+  relation (port, knot) = do+    relatives <- traverse (relative port knot) [still, middle, strong]+    check "leaf lean relative to the tangent is breeze-invariant up to normalization"+      (all (uncurry positiveMultiple) (zip relatives (drop 1 relatives)))+  relative :: StemPort -> Int -> GardenPlant -> IO (ExactVector, ExactVector, ExactVector)+  relative port knot plant = do+    let trail = gardenStemTrail plant+        steps = trailSteps (locatedValue trail)+    (tangent, point) <- maybe (fail "missing stem knot") pure+      ((,) <$> (startJet <$> Seq.lookup knot steps) <*> lookupIndex knot (stemKnots trail))+    let ExactVector tx ty = tangent+        (px, py) = exactPointCoordinates point+    frame <- maybe (fail "stationary stem tangent") pure+      (affineIso2 (affine2 tangent (ExactVector (negate ty) tx) (ExactVector px py)))+    pure (affineColumns (affineIsoMap (composeAffineIso2 (inverseAffineIso2 frame)+      (motifPort (gardenStem plant) port))))+  positiveMultiple :: (ExactVector, ExactVector, ExactVector) -> (ExactVector, ExactVector, ExactVector) -> Bool+  positiveMultiple (a, b, offset) (c, d, offset') =+    offset == ExactVector 0 0 && offset' == ExactVector 0 0+      && cross a c == 0 && cross b d == 0 && dot a c > 0 && dot b d > 0+      && dot a c * dot d d == dot b d * dot c c++stemKnots :: Located OpenTrail -> [ExactPoint]+stemKnots trail = toList (Seq.scanl (\point step -> translateExactPoint point (curveStepEnd step))+  (location trail) (trailSteps (locatedValue trail)))++lookupIndex :: Int -> [a] -> Maybe a+lookupIndex index = Seq.lookup index . Seq.fromList++blossomFrames :: GardenPlant -> (AffineIso2, AffineIso2)+blossomFrames plant = (motifPort (gardenStem plant) BlossomSocket, motifPort (gardenBlossom plant) BlossomRoot)++stemFrames :: GardenPlant -> [AffineIso2]+stemFrames plant = motifPort (gardenStem plant) <$> [minBound .. maxBound]++cross :: ExactVector -> ExactVector -> ExactRational+cross (ExactVector a b) (ExactVector c d) = a * d - b * c++dot :: ExactVector -> ExactVector -> ExactRational+dot (ExactVector a b) (ExactVector c d) = a * c + b * d  parts :: [GardenPart] parts = [NightSky, Moon, Ground, Stems, Leaves, Blossoms, Ribbon, Fireflies]

@@ -3,13 +3,21 @@ import Control.Monad (unless) import Data.Foldable (toList, traverse_) import Data.List (nub)+import qualified Data.Sequence as Seq import Moonlight.Planar.Affine (Affine2, affine2, affineIsoMap, composeAffine2, identityAffine2, transformPoint)-import Moonlight.Planar.Curve (ClosedTrail, Located, location, transformLocatedClosedTrail)+import Moonlight.Planar.Curve+  ( ClosedTrail, Located, Subpath (..), closedTrailSteps, locate, location, locatedValue, openTrail+  , transformLocatedClosedTrail )+import Moonlight.Planar.Curve.Frame (exactTrailSite) import Moonlight.Planar.Curve.Lowering (loweringPolicy)-import Moonlight.Planar.Curve.Region (CurveComponent (..), lowerSimpleRegion)+import Moonlight.Planar.Curve.Measure (distance, measurePolicy, radicalPrecision, sitePoint)+import Moonlight.Planar.Curve.Proximity (ClearanceVerdict (..), clearance)+import Moonlight.Planar.Curve.Region (CurveComponent (..), certifiedPointLocation, lowerSimpleRegion, subdivisionBudget) import Moonlight.Planar.Exhibit.IllustrationStudy-import Moonlight.Planar.Exact (ExactPoint, ExactRational, ExactVector (..), exactPoint, positiveOne)-import Moonlight.Planar.Region (planarRegionComponents, polygonHoleLoops)+import Moonlight.Planar.Exact+  ( ExactPoint, ExactRational, ExactVector (..), exactHalf, exactPoint, exactPointCoordinates, positiveExact+  , positiveOne, unitOne, unitZero )+import Moonlight.Planar.Region (RegionPointLocation (..), planarRegionComponents, polygonHoleLoops) import Moonlight.Planar.Illustration (PictureAlgebra (..), Paint (..), foldPicture)  -- These are artistic dependency tests, not another curve-equivalence oracle.@@ -45,10 +53,15 @@   traverse_ checkRejected     [(LeftHornSweep,46),(EyeSpacing,39),(EyeTilt,16),(CloakFullness,56),(FullerWidth,0)]   checkBladeHole defaultControls-  case editControl FullerWidth 24 defaultControls of-    Left refusal -> ioError (userError (show refusal))-    Right wide -> checkBladeHole wide-  putStrLn "illustration study: semantic edits, stable anchors and admitted blade hole ok"+  traverse_+    (\width -> either (ioError . userError . show) checkBladeHole (editControl FullerWidth (fromInteger width) defaultControls))+    fullerWidthBounds+  checkHornBases defaultControls+  traverse_+    (\sweep -> either (ioError . userError . show) checkHornBases (editControl LeftHornSweep (fromInteger sweep) defaultControls))+    hornSweepBounds+  putStrLn ("illustration study: semantic edits and stable anchors ok; fuller certified strictly inside the blade at the default and FullerWidth "+    <> show fullerWidthBounds <> "; horn bases certified inside the mask at the default and LeftHornSweep " <> show hornSweepBounds)  checkEdit :: (StudyControl, ExactRational, [StudyPart]) -> IO () checkEdit (control,value,affected) = case editControl control value defaultControls of@@ -106,13 +119,70 @@     LinearGradient a b stops -> LinearGradient (transformPoint frame a) (transformPoint frame b) stops     other -> other --- At the study's output scale, the actual outer/hole curves must lower into--- one admitted polygon with one hole, including the widest allowed fuller.+-- The painting fills the blade with the fuller under EvenOdd, so the fuller+-- must lie strictly inside it: the certificate proves both curves simple,+-- disjoint and wound as outer and hole, and the fuller nested inside the+-- blade, and refuses a lowered polygon that nests otherwise. The tested scope+-- is the default controls and the fuller's editable bounds.+fullerWidthBounds :: [Integer]+fullerWidthBounds = [5, 24]+ checkBladeHole :: StudyControls -> IO ()-checkBladeHole controls = case loweringPolicy positiveOne identityAffine2 20 8192 of-  Left refusal -> ioError (userError (show refusal))-  Right policy -> case lowerSimpleRegion policy-    [CurveComponent (partContour controls Blade) [partContour controls Fuller]] of-      Left refusal -> ioError (userError (show refusal))-      Right (region,_) -> check "pierced blade retains exactly one admitted hole"-        (map (length . polygonHoleLoops) (planarRegionComponents region) == [1])+checkBladeHole controls =+  case (loweringPolicy positiveOne identityAffine2 20 8192, subdivisionBudget 12 4096 4096) of+    (Left refusal, _) -> ioError (userError (show refusal))+    (_, Left refusal) -> ioError (userError (show refusal))+    (Right policy, Right budget) -> case lowerSimpleRegion policy budget+      [CurveComponent (partContour controls Blade) [partContour controls Fuller]] of+        Left refusal -> ioError (userError (show refusal))+        Right (region,_,_) -> check "pierced blade retains exactly one admitted hole"+          (map (length . polygonHoleLoops) (planarRegionComponents region) == [1])++-- The horns are painted beneath the mask and must attach under it: each+-- horn's base, the closing step of its contour across its root, lies inside+-- the mask. A connected segment disjoint from the mask curve with an+-- endpoint inside is wholly inside, since leaving would cross the curve. The+-- base's endpoints are exact sites of the closing step, certified inside by+-- the mask's curve evidence, and strict clearance at zero between the step+-- and the mask curve certifies them disjoint. The tested scope is the+-- default controls and the left horn's editable sweep bounds; the mask is+-- fixed and the sweep moves only the horn's tip.+hornSweepBounds :: [Integer]+hornSweepBounds = [-45, 45]++checkHornBases :: StudyControls -> IO ()+checkHornBases controls = do+  lowering <- orFail (loweringPolicy positiveOne identityAffine2 20 8192)+  budget <- orFail (subdivisionBudget 12 4096 4096)+  tolerance <- orFail (positiveExact 1)+  precision <- orFail (radicalPrecision 64)+  zero <- orFail (distance 0)+  let mask = partContour controls Mask+      measuring = measurePolicy tolerance precision budget+  (_, _, evidence) <- orFail (lowerSimpleRegion lowering budget [CurveComponent mask []])+  traverse_+    (\part -> do+        let contour = partContour controls part+            source = ClosedSubpath contour+            steps = closedTrailSteps (locatedValue contour)+            closing = Seq.length steps - 1+        start <- orFail (exactTrailSite source closing unitZero)+        end <- orFail (exactTrailSite source closing unitOne)+        check (show part <> " base spans its root")+          (midpoint (sitePoint start) (sitePoint end) == portPoint controls part)+        check (show part <> " base endpoints certified inside the mask")+          (map (certifiedPointLocation evidence) [sitePoint start, sitePoint end] == [Just RegionInterior, Just RegionInterior])+        base <- maybe (ioError (userError (show part <> " has no closing step"))) pure (Seq.lookup closing steps)+        verdict <- orFail (clearance measuring zero (OpenSubpath (locate (sitePoint start) (openTrail (Seq.singleton base)))) (ClosedSubpath mask))+        case verdict of+          ClearanceHolds _ -> pure ()+          other -> ioError (userError (show part <> " base meets the mask curve: " <> show other)))+    [LeftHorn, RightHorn]+ where+  orFail :: Show refusal => Either refusal value -> IO value+  orFail = either (ioError . userError . show) pure+  midpoint :: ExactPoint -> ExactPoint -> ExactPoint+  midpoint a b =+    let (ax, ay) = exactPointCoordinates a+        (bx, by) = exactPointCoordinates b+     in exactPoint (exactHalf * (ax + bx)) (exactHalf * (ay + by))

@@ -45,6 +45,13 @@         (path (Seq.singleton (OpenSubpath (locate (exactPoint 9 4) mempty))))))           == Just (9,4,9,4))   traverse_ containment shapes+  traverse_ (\picture -> check "layout bounds reducer agrees with envelope bounds"+    (layoutBounds picture == boundsObservation (geometryEnvelope picture)))+    ([mempty, art, place frame art, place collapse art, place unshear (place shear art)+      , annotate () (opacity unitZero clipped), motifPicture (box 13), strokeOf mempty+      , strokeOf (path (Seq.singleton (OpenSubpath (locate (exactPoint 9 4) mempty)))) ]+      <> fmap (strokeOf . path . Seq.singleton . OpenSubpath . locate (exactPoint 0 0) . openTrail . Seq.singleton) shapes)+  traverse_ (controlLaws frame shear unshear collapse) controlFixtures   layoutLaws   putStrLn "layout: exact support, conservative geometry, coherent linear arrangement ok" @@ -93,6 +100,104 @@  where   dot (ExactVector x y) (ExactVector a b) = x*a+y*b +-- Bounds as layout sees them. Aligning an edge to a target moves the identity+-- port by the target minus that edge, so the edge read back is target-independent;+-- empty geometry does not move for any target.+layoutBounds :: Picture () -> Maybe (ExactRational, ExactRational, ExactRational, ExactRational)+layoutBounds picture+  | edge Horizontal unitZero 0 /= edge Horizontal unitZero 1 = Nothing+  | otherwise = Just (edge Horizontal unitZero 0, edge Vertical unitZero 0, edge Horizontal unitOne 0, edge Vertical unitOne 0)+ where+  edge :: LayoutAxis -> UnitInterval -> ExactRational -> ExactRational+  edge axis fraction target =+    let (x, y) = exactPointCoordinates (transformPoint+          (affineIsoMap (motifPort (alignMotif axis fraction target (probe picture)) Root)) (exactPoint 0 0))+     in target - case axis of+          Horizontal -> x+          Vertical -> y++probe :: Picture () -> Motif Port ()+probe picture = motif picture (const identityAffineIso2)++-- Relative controls of a trail with every shape and two constant steps. The+-- expected support is the anchor and each step's controls, enumerated by hand+-- in absolute coordinates; shared starts appear once, which cannot move support.+chain :: OpenTrail+chain = openTrail (Seq.fromList+  [ curveStep line (ExactVector 3 0)+  , curveStep (quadratic (ExactVector 1 4)) (ExactVector 2 0)+  , curveStep (cubic (ExactVector (-1) (-5)) (ExactVector 4 2)) (ExactVector 0 3)+  , curveStep line (ExactVector 0 0)+  , curveStep (quadratic (ExactVector 0 0)) (ExactVector 0 0)+  , curveStep (rationalQuadratic (ExactVector 2 (-2)) positiveTwo positiveOne) (ExactVector (-6) 1) ])++chainPoints :: NonEmpty ExactPoint+chainPoints = exactPoint 1 2 :| [exactPoint 4 2, exactPoint 5 6, exactPoint 6 2, exactPoint 5 (-3)+  , exactPoint 10 4, exactPoint 6 5, exactPoint 8 3, exactPoint 0 6]++-- The derived closing step runs from (0,6) back to the anchor through (-3,5).+closedChain :: Located ClosedTrail+closedChain = locate (exactPoint 1 2) (closeWith (quadratic (ExactVector (-3) (-1))) chain)++data ControlFixture = ControlFixture String (Picture ()) (NonEmpty ExactPoint)++controlFixtures :: [ControlFixture]+controlFixtures =+  [ ControlFixture "multi-step open trail" (strokeOf (subpaths [OpenSubpath (locate (exactPoint 1 2) chain)])) chainPoints+  , ControlFixture "closed trail with derived closing step" (fill NonZero (Solid (RGB 1 2 3)) (closedChain :| []))+      (chainPoints <> (exactPoint (-3) 5 :| []))+  , ControlFixture "located empty open trail" (strokeOf (subpaths [OpenSubpath (locate (exactPoint 9 4) mempty)]))+      (exactPoint 9 4 :| [])+  , ControlFixture "located empty closed trail" (strokeOf (subpaths [ClosedSubpath (locate (exactPoint (-2) 7) (closeWith line mempty))]))+      (exactPoint (-2) 7 :| [])+  , ControlFixture "sibling located empty and multi-step trails"+      (strokeOf (subpaths [OpenSubpath (locate (exactPoint 20 (-8)) mempty), OpenSubpath (locate (exactPoint 1 2) chain)]))+      (exactPoint 20 (-8) :| toList chainPoints) ]++-- Every fixture under identity, nested frames (each control point mapped once by+-- the composite), a nested inverse shear that must not rebox, and singular maps.+controlLaws :: Affine2 -> Affine2 -> Affine2 -> Affine2 -> ControlFixture -> IO ()+controlLaws frame shear unshear collapse (ControlFixture label picture points) = do+  let rankOne = affine2 (ExactVector 1 2) (ExactVector 2 4) (ExactVector 0 1)+  traverse_ (\(scope, scoped, expected) -> do+      let e = geometryEnvelope scoped+          bounds = Just (pointsBounds expected)+      traverse_ (\u -> check (label <> ", " <> scope <> ": support")+        (geometrySupport u e == Just (maximum (project u <$> expected)))) directions+      check (label <> ", " <> scope <> ": envelope bounds") (boundsObservation e == bounds)+      check (label <> ", " <> scope <> ": layout bounds") (layoutBounds scoped == bounds))+    [ ("identity", picture, points)+    , ("nested frames", place frame (place shear picture), transformPoint frame . transformPoint shear <$> points)+    , ("nested inverse shear", place unshear (place shear picture), points)+    , ("rank-one map", place rankOne picture, transformPoint rankOne <$> points)+    , ("collapse", place frame (place collapse picture), transformPoint frame (exactPoint 4 9) :| []) ]+ where+  project :: ExactVector -> ExactPoint -> ExactRational+  project (ExactVector x y) point = let (px, py) = exactPointCoordinates point in x * px + y * py++pointsBounds :: NonEmpty ExactPoint -> (ExactRational, ExactRational, ExactRational, ExactRational)+pointsBounds points =+  let coordinates = exactPointCoordinates <$> points+   in (minimum (fst <$> coordinates), minimum (snd <$> coordinates), maximum (fst <$> coordinates), maximum (snd <$> coordinates))++chainLayoutLaws :: IO ()+chainLayoutLaws = do+  let open = probe (strokeOf (subpaths [OpenSubpath (locate (exactPoint 1 2) chain)]))+      closed = probe (fill NonZero (Solid (RGB 1 2 3)) (closedChain :| []))+      port :: Motif Port () -> ExactPoint+      port value = transformPoint (affineIsoMap (motifPort value Root)) (exactPoint 0 0)+  check "multi-step arrangement from control bounds"+    (fmap port (toList (arrangeMotifs Horizontal 2 (Seq.fromList [open, closed, open])))+      == [exactPoint 0 0, exactPoint 15 0, exactPoint 27 0])+  check "multi-step vertical midpoint alignment"+    (port (alignMotif Vertical unitHalf 0 open) == exactPoint 0 (negate (3 * exactHalf)))++subpaths :: [Subpath] -> Path+subpaths = path . Seq.fromList++strokeOf :: Path -> Picture ()+strokeOf = stroke (pen positiveOne LocalUnits)+ layoutLaws :: IO () layoutLaws = do   let original = box 10@@ -114,6 +219,7 @@       (transformPoint (affineIsoMap (motifPort value Root)) (exactPoint 0 0)         == exactPoint (boundsMinimumX bounds) (boundsMinimumY bounds))) baseline   check "empty layout identity" (ports [alignMotif Horizontal unitOne 0 empty] == ports [empty])+  chainLayoutLaws  box :: ExactRational -> Motif Port () box width = motif (fill NonZero (Solid (RGB 1 2 3))

@@ -3,21 +3,146 @@ import Control.Monad (unless) import Data.Foldable (toList, traverse_) import qualified Data.List.NonEmpty as NonEmpty+import Data.Sequence (Seq) import qualified Data.Sequence as Seq-import Moonlight.Planar.Curve (Path, Subpath (..), path, transformPath)+import Moonlight.Planar.Affine (affineColumns, affineIsoMap)+import Moonlight.Planar.Curve+  ( CurveStep, Located, OpenTrail, Path, Subpath (..), jetStep, locate, locatedValue+  , location, openTrail, path, splitStep, stepControlPoints, stepJetFirst, trailSteps+  , transformPath )+import Moonlight.Planar.Curve.Authoring (profileRails)+import Moonlight.Planar.Curve.Frame+  ( FrameSite (..), MeasuredFrame, measuredFrameIso, measuredFrameScaleSquared+  , measuredFrameSite, measuredFrameTangent )+import Moonlight.Planar.Curve.Measure+  ( ArcSample, MeasurePolicy, lengthBounds, lengthEnclosureLower, lengthEnclosureUpper+  , measureSubpath, sampleResidual, sampleSite, siteParameter, sitePoint, siteStepIndex )+import Moonlight.Planar.Exact+  ( ExactPoint, ExactRational, ExactVector (..), exactHalf, exactPoint, exactPointCoordinates+  , exactRational, unitHalf, unitIntervalValue, unitOne ) import Moonlight.Planar.Exhibit.SpaceSword import Moonlight.Planar.Illustration (Picture, PictureAlgebra (..), foldPicture)  tests :: IO () tests = do-  let baseline = spaceSwordPicture defaultSpaceSwordControls-      overcharged = spaceSwordPicture overchargedSpaceSwordControls-      affected = [BladeAura, BladeShell, BladeCore, BladeRunes, IonWake]-  traverse_ (checkPart baseline overcharged affected) [minBound .. maxBound]-  check "semantic charge/sweep edit changes the sword"-    (baseline /= overcharged)-  putStrLn "space sword: complete typed composition and selective overcharge edit ok"+  let chargeOnly = defaultSpaceSwordControls { bladeCharge = unitOne }+      sweepOnly = defaultSpaceSwordControls { bladeSweep = 40 }+      blade = [BladeAura, BladeShell, BladeCore, BladeRunes, IonWake]+  baseline <- require (spaceSwordPicture defaultSpaceSwordControls)+  overcharged <- require (spaceSwordPicture overchargedSpaceSwordControls)+  charged <- require (spaceSwordPicture chargeOnly)+  swept <- require (spaceSwordPicture sweepOnly)+  traverse_ (checkPart baseline overcharged blade) [minBound .. maxBound]+  traverse_ (checkPart baseline charged [BladeAura, BladeCore, BladeRunes, IonWake]) [minBound .. maxBound]+  traverse_ (checkPart baseline swept blade) [minBound .. maxBound]+  check "semantic charge/sweep edit changes the sword" (baseline /= overcharged)+  base <- require (runeFrames defaultSpaceSwordControls)+  chargedRunes <- require (runeFrames chargeOnly)+  sweptRunes <- require (runeFrames sweepOnly)+  check "charge leaves the rune stations and frames fixed" (base == chargedRunes)+  check "sweep moves every rune frame"+    (and (NonEmpty.zipWith (\a b -> measuredFrameIso a /= measuredFrameIso b) base sweptRunes))+  traverse_ runeLaws [defaultSpaceSwordControls, overchargedSpaceSwordControls, chargeOnly, sweepOnly]+  traverse_ centerlineIsRailMidpoint [defaultSpaceSwordControls, overchargedSpaceSwordControls]+  putStrLn "space sword: complete typed composition, measured rune run and selective edits ok" +-- Station distance and frame scale are separate bounds. Each rune sample is+-- checked against an independent measurement of the centerline up to its+-- site; each frame against the jet of the centerline's own step there.+runeLaws :: SpaceSwordControls -> IO ()+runeLaws controls = do+  frames <- require (runeFrames controls)+  (measuring, _) <- require runeMeasurePolicy+  fractions <- traverse require [exactRational 1 5, exactRational 1 2, exactRational 4 5]+  let centerline = channelCenterline (unitIntervalValue (bladeCharge controls)) (bladeSweep controls)+  total <- lengthBounds <$> require (measureSubpath measuring (OpenSubpath centerline))+  samples <- traverse sampleOf (toList frames)+  check "three runes" (length samples == 3)+  check "runes follow the run's order along the centerline"+    (and (zipWith (<) (key <$> samples) (drop 1 (key <$> samples))))+  traverse_ (\(fraction, sample, frame) -> do+      let residual = sampleResidual sample+      check "station residual within the arc-length tolerance" (residual <= exactHalf ^ (3 :: Int))+      (lower, upper) <- prefixLength measuring centerline sample+      check "station distance agrees with an independent prefix measurement"+        (lower - fraction * lengthEnclosureUpper total <= residual+          && fraction * lengthEnclosureLower total - upper <= residual)+      tangent <- stepTangent centerline sample+      let (column, normal, offset) = affineColumns (affineIsoMap (measuredFrameIso frame))+          ExactVector cx cy = column+          (px, py) = exactPointCoordinates (sitePoint (sampleSite sample))+      check "frame tangent is the step's own jet" (measuredFrameTangent frame == tangent)+      check "frame tangent column points along the jet" (cross column tangent == 0 && dot column tangent > 0)+      check "frame columns are the tangent and its left normal" (normal == ExactVector (negate cy) cx)+      check "frame origin is the station" (offset == ExactVector px py)+      check "frame scale within its normalization bound"+        (dot column column == measuredFrameScaleSquared frame+          && measuredFrameScaleSquared frame <= 1+          && 1 - measuredFrameScaleSquared frame <= exactHalf ^ (20 :: Int)))+    (zip3 fractions samples (toList frames))+ where+  key :: ArcSample -> (Int, ExactRational)+  key sample = (siteStepIndex (sampleSite sample), unitIntervalValue (siteParameter (sampleSite sample)))++sampleOf :: MeasuredFrame -> IO ArcSample+sampleOf frame = case measuredFrameSite frame of+  SampledSite sample -> pure sample+  ExactSite _ -> fail "rune frame is not an arc-length station"++-- The centerline's steps before the sample, then its own step cut at the+-- sample's parameter, measured afresh with the same policy.+prefixLength :: MeasurePolicy -> Located OpenTrail -> ArcSample -> IO (ExactRational, ExactRational)+prefixLength measuring centerline sample = do+  step <- sampleCurveStep centerline sample+  let steps = trailSteps (locatedValue centerline)+      prefix = Seq.take (siteStepIndex (sampleSite sample)) steps Seq.|> fst (splitStep (siteParameter (sampleSite sample)) step)+  measured <- require (measureSubpath measuring (OpenSubpath (locate (location centerline) (openTrail prefix))))+  let bounds = lengthBounds measured+  pure (lengthEnclosureLower bounds, lengthEnclosureUpper bounds)++stepTangent :: Located OpenTrail -> ArcSample -> IO ExactVector+stepTangent centerline sample = do+  step <- sampleCurveStep centerline sample+  pure (stepJetFirst (jetStep (siteParameter (sampleSite sample)) step))++sampleCurveStep :: Located OpenTrail -> ArcSample -> IO CurveStep+sampleCurveStep centerline sample =+  maybe (fail "sample step outside the centerline") pure+    (Seq.lookup (siteStepIndex (sampleSite sample)) (trailSteps (locatedValue centerline)))++-- The derived centerline is the exact average of the channel's two rails at+-- the channel's tension, one half.+centerlineIsRailMidpoint :: SpaceSwordControls -> IO ()+centerlineIsRailMidpoint controls = do+  let charge = unitIntervalValue (bladeCharge controls)+      sweep = bladeSweep controls+      (positive, negative) = profileRails unitHalf (channelStations charge sweep)+      center = channelCenterline charge sweep+      controlsOf :: Located OpenTrail -> Seq [ExactVector]+      controlsOf = fmap (toList . stepControlPoints) . trailSteps . locatedValue+  check "centerline anchor is the rails' midpoint"+    (location center == midpointPoint (location positive) (location negative))+  check "centerline controls are the rails' midpoints"+    (Seq.length (controlsOf center) == Seq.length (controlsOf positive)+      && Seq.length (controlsOf center) == Seq.length (controlsOf negative)+      && controlsOf center == Seq.zipWith (zipWith midpointVector) (controlsOf positive) (controlsOf negative))++midpointPoint :: ExactPoint -> ExactPoint -> ExactPoint+midpointPoint a b =+  let (ax, ay) = exactPointCoordinates a+      (bx, by) = exactPointCoordinates b+   in exactPoint ((ax + bx) * exactHalf) ((ay + by) * exactHalf)++midpointVector :: ExactVector -> ExactVector -> ExactVector+midpointVector (ExactVector ax ay) (ExactVector bx by) =+  ExactVector ((ax + bx) * exactHalf) ((ay + by) * exactHalf)++cross :: ExactVector -> ExactVector -> ExactRational+cross (ExactVector a b) (ExactVector c d) = a * d - b * c++dot :: ExactVector -> ExactVector -> ExactRational+dot (ExactVector a b) (ExactVector c d) = a * c + b * d+ checkPart   :: Picture SpaceSwordPart   -> Picture SpaceSwordPart@@ -49,6 +174,9 @@     }   retain :: Maybe SpaceSwordPart -> Path -> [Path]   retain inherited curve = if inherited == Just selected then [curve] else []++require :: Show e => Either e a -> IO a+require = either (fail . show) pure  check :: String -> Bool -> IO () check label condition = unless condition (fail label)