Mutable.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

module Moonlight.Triangulation.Internal.Mutable
  ( MutableDcel (..)
  , newMutableDcel
  , thawTriangulation
  , thawTriangulationDense
  , freezeTriangulation
  , pointCapacity
  , halfEdgeCapacity
  , pointCount
  , connectedCount
  , directedEdgeCount
  , faceCount
  , pointAt
  , lookupPointVertex
  , activatePointIndex
  , activateBatchPointIndex
  , discardBatchPointIndex
  , identityIndexActive
  , readPointX
  , readPointY
  , writePoint
  , vertexDataAt
  , writeVertexData
  , payloadsPristine
  , resetEdgeData
  , resetFaceData
  , edgeOriginPoint
  , appendVertex
  , appendVertexCoordinates
  , ensurePointCapacity
  , markConnected
  , isConnected
  , addEdge
  , addEdgeBlock
  , addFace
  , addFaceBlock
  , ensureCellCapacity
  , truncatePoints
  , truncateDirectedEdges
  , truncateFaces
  , swapRemoveUndirectedEdge
  , swapRemoveFace
  , swapRemoveVertex
  , linkEdges
  , setCycle3
  , faceEdges
  , readOrigin
  , writeOrigin
  , readNext
  , writeNext
  , readPrevious
  , writePrevious
  , readFace
  , writeFace
  , readVertexOut
  , writeVertexOut
  , readFaceEdge
  , writeFaceEdge
  , readConstraint
  , setConstraint
  , clearConstraint
  ) where

import Control.Monad (foldM, forM_, unless, when)
import Data.Bits (xor)
import Control.Monad.ST (ST)
import qualified Data.IntSet as IntSet
import Data.STRef
  ( STRef
  , modifySTRef'
  , newSTRef
  , readSTRef
  , writeSTRef
  )
import Data.Word (Word8, Word32)
import Moonlight.Triangulation.Handles.HandleDefs
  ( DirectedEdgeId (..)
  , FaceId (..)
  , UndirectedEdgeId (..)
  , VertexId (..)
  )
import Moonlight.Triangulation.Internal.BoxedPaged
import Moonlight.Triangulation.Internal.PackedIndex (noIndex, packIndex)
import Moonlight.Triangulation.Internal.Paged
import Moonlight.Triangulation.Internal.PointIndex
  ( MutablePointIndex
  , MutablePointIndexUpdate (..)
  , PointIndex
  , buildPointIndex
  , emptyPointIndex
  , insertPointIndex
  , lookupMutablePoint
  , newMutablePointIndex
  , pointIndexCandidates
  , relocateMutablePoint
  , relocatePointIndex
  , removeMutablePoint
  , removePointIndex
  , seedMutablePointIndex
  )
import Moonlight.Triangulation.Math (canonicalPoint)
import Moonlight.Triangulation.Internal.Representation (Triangulation (..))
import Moonlight.Triangulation.Internal.Types (BuildError (..), ElementDefaults (..), Point (..))
-- | Dormant carries the inherited index through mutations as unforced pure
-- updates; persistent Active is the same index forced and kept strict because
-- a singleton lookup already proved someone is asking. Batch Active is the
-- existing open-addressed owner scoped to one dense identity program. Missing
-- means publication owes a lazy whole-mesh rebuild to any eventual asker.
data MutablePointIndexState s
  = DormantPointIndex PointIndex
  | ActivePersistentPointIndex !PointIndex
  | ActiveBatchPointIndex !(MutablePointIndex s)
  | MissingPointIndex

data MutableDcel s vertex directed undirected face = MutableDcel
  { mdPointX :: !(MutablePaged s Double)
  , mdPointY :: !(MutablePaged s Double)
  , mdPointIndex :: !(STRef s (MutablePointIndexState s))
  , mdVertexOut :: !(MutablePaged s Word32)
  , mdVertexData :: !(MutableBoxedPaged s vertex)
  , mdNewConnected :: !(MutablePaged s Word8)
  , mdRecycledNew :: !(STRef s IntSet.IntSet)
  , mdHalfTopology :: !(MutablePaged s Word32)
  , mdDirectedData :: !(MutableBoxedPaged s directed)
  , mdUndirectedData :: !(MutableBoxedPaged s undirected)
  , mdConstraint :: !(MutablePaged s Word8)
  , mdFaceEdge :: !(MutablePaged s Word32)
  , mdFaceData :: !(MutableBoxedPaged s face)
  , mdPointCount :: !(STRef s Int)
  , mdConnectedCount :: !(STRef s Int)
  , mdHalfCount :: !(STRef s Int)
  , mdFaceCount :: !(STRef s Int)
  , mdConstraintCount :: !(STRef s Int)
  , mdConstraintEdges :: !(STRef s IntSet.IntSet)
  , mdLastFace :: !(STRef s Int)
  , mdInitialPointCount :: {-# UNPACK #-} !Int
  , mdPointCapacity :: {-# UNPACK #-} !Int
  , mdHalfCapacity :: {-# UNPACK #-} !Int
  , mdFaceCapacity :: {-# UNPACK #-} !Int
  , -- | No element payload plane held a materialized page at thaw. Nothing
    -- inside a transaction can write one: the three planes are written only
    -- through the persistent setters, which run outside one, and both the
    -- rewrite reset and the swap-compaction relocation below are no-ops while
    -- this holds. So it is constant for the transaction's whole life, and a
    -- rewrite decides in a predictable branch that it has no label to move.
    mdPayloadsPristine :: !Bool
  , mdElementDefaults :: !(ElementDefaults directed undirected face)
  }

newMutableDcel :: ElementDefaults directed undirected face -> Int -> ST s (MutableDcel s vertex directed undirected face)
newMutableDcel defaults maximumVertices = newMutableDcelFrom DenseTransaction defaults maximumVertices Nothing

-- | Open a local-edit transaction: copy-on-write pages, publication
-- proportional to dirtied pages. The section for singleton persistent verbs.
thawTriangulation
  :: Int
  -> Triangulation mode vertex directed undirected face
  -> ST s (MutableDcel s vertex directed undirected face)
thawTriangulation maximumVertices triangulation =
  newMutableDcelFrom
    LocalTransaction
    (triElementDefaults triangulation)
    maximumVertices
    (Just triangulation)

-- | Open a batch transaction: one dense copy up front, flat reads and writes
-- thereafter. The section for sessions and every other many-edit operation.
thawTriangulationDense
  :: Int
  -> Triangulation mode vertex directed undirected face
  -> ST s (MutableDcel s vertex directed undirected face)
thawTriangulationDense maximumVertices triangulation =
  newMutableDcelFrom
    DenseTransaction
    (triElementDefaults triangulation)
    maximumVertices
    (Just triangulation)

newMutableDcelFrom
  :: TransactionShape
  -> ElementDefaults directed undirected face
  -> Int
  -> Maybe (Triangulation mode vertex directed undirected face)
  -> ST s (MutableDcel s vertex directed undirected face)
newMutableDcelFrom shape mdElementDefaults maximumVertices source = do
  let !existingVertices = maybe 0 (pagedLength . triPointX) source
      !existingHalfEdges = maybe 0 ((`quot` 4) . pagedLength . triHalfTopology) source
      !existingFaces = maybe 1 (pagedLength . triFaceEdge) source
      !growthVertexCapacity = max 1 (max existingVertices maximumVertices)
      !vertexCapacity = growthVertexCapacity
      -- Euler bounds a planar triangulation's LIVE cells at 3n - 6 undirected
      -- edges and 2n - 4 faces, but these arenas are append-only with no free
      -- list, so what must be reserved is CUMULATIVE allocation, not the live
      -- maximum. Measured: a complete 5-vertex triangulation (9 edges, 6 faces,
      -- V - E + F = 2) requests a seventh face without gaining a vertex, so
      -- some operation abandons a slot it will never reclaim. The slack below
      -- is headroom over that leakage, not a bound derived from it.
      !halfCapacity = max existingHalfEdges (max 2 (8 * growthVertexCapacity + 16))
      !faceCapacity = max existingFaces (max 1 (3 * growthVertexCapacity + 8))
      vertexDataBase = maybe (emptyBoxedPaged Nothing) triVertexData source
      directedDataBase = maybe (emptyBoxedPaged (Just (defaultDirectedEdgeData mdElementDefaults))) triDirectedData source
      undirectedDataBase = maybe (emptyBoxedPaged (Just (defaultUndirectedEdgeData mdElementDefaults))) triUndirectedData source
      faceDataBase = maybe (emptyBoxedPaged (Just (defaultFaceData mdElementDefaults))) triFaceData source
      constraintBaseCount = maybe 0 triConstraintCount source
      constraintBaseEdges = maybe IntSet.empty triConstraintEdges source
      pointIndexBase = maybe MissingPointIndex (DormantPointIndex . triPointIndex) source
  mdPointX <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triPointX) source
  mdPointY <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triPointY) source
  mdVertexOut <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triVertexOut) source
  mdVertexData <- thawBoxedPaged vertexDataBase
  mdNewConnected <- newLocalMutablePaged (vertexCapacity - existingVertices)
  mdRecycledNew <- newSTRef IntSet.empty
  mdHalfTopology <- maybe (newMutablePaged (4 * halfCapacity)) (thawPagedShaped shape (4 * halfCapacity) . triHalfTopology) source
  mdDirectedData <- thawBoxedPaged directedDataBase
  mdUndirectedData <- thawBoxedPaged undirectedDataBase
  mdConstraint <- maybe (newMutablePaged (halfCapacity `quot` 2)) (thawPagedShaped shape (halfCapacity `quot` 2) . triConstraint) source
  mdFaceEdge <-
    case source of
      Just triangulation -> thawPagedShaped shape faceCapacity (triFaceEdge triangulation)
      Nothing -> do
        freshFaceEdges <- newLocalMutablePaged faceCapacity
        writePaged freshFaceEdges 0 noIndex
        pure freshFaceEdges
  mdFaceData <- thawBoxedPaged faceDataBase
  mdPointCount <- newSTRef existingVertices
  mdPointIndex <- newSTRef pointIndexBase
  mdConnectedCount <- newSTRef existingVertices
  mdHalfCount <- newSTRef existingHalfEdges
  mdFaceCount <- newSTRef existingFaces
  mdConstraintCount <- newSTRef constraintBaseCount
  mdConstraintEdges <- newSTRef constraintBaseEdges
  mdLastFace <- newSTRef (if existingFaces > 1 then 1 else 0)
  let !mdPayloadsPristine =
        boxedThawPristine mdDirectedData
          && boxedThawPristine mdUndirectedData
          && boxedThawPristine mdFaceData
  pure
    MutableDcel
      { mdInitialPointCount = existingVertices
      , mdPointCapacity = vertexCapacity
      , mdHalfCapacity = halfCapacity
      , mdFaceCapacity = faceCapacity
      , ..
      }

freezeTriangulation :: MutableDcel s vertex directed undirected face -> ST s (Either BuildError (Triangulation mode vertex directed undirected face))
freezeTriangulation MutableDcel
  { mdPointX
  , mdPointY
  , mdPointIndex
  , mdVertexOut
  , mdVertexData
  , mdHalfTopology
  , mdDirectedData
  , mdUndirectedData
  , mdConstraint
  , mdFaceEdge
  , mdFaceData
  , mdPointCount
  , mdHalfCount
  , mdFaceCount
  , mdConstraintCount
  , mdConstraintEdges
  , mdElementDefaults
  } = do
    vertices <- readSTRef mdPointCount
    halfEdges <- readSTRef mdHalfCount
    faces <- readSTRef mdFaceCount
    triConstraintCount <- readSTRef mdConstraintCount
    triConstraintEdges <- readSTRef mdConstraintEdges
    vertexDataOutcome <- freezeBoxedPaged vertices mdVertexData
    directedDataOutcome <- freezeBoxedPaged halfEdges mdDirectedData
    undirectedDataOutcome <- freezeBoxedPaged (halfEdges `quot` 2) mdUndirectedData
    faceDataOutcome <- freezeBoxedPaged faces mdFaceData
    case
        (,,,)
          <$> vertexDataOutcome
          <*> directedDataOutcome
          <*> undirectedDataOutcome
          <*> faceDataOutcome
      of
        Left obstruction -> pure (Left (PayloadStorageFailure obstruction))
        Right (triVertexData, triDirectedData, triUndirectedData, triFaceData) -> do
          triPointX <- freezePaged vertices mdPointX
          triPointY <- freezePaged vertices mdPointY
          pointIndexState <- readSTRef mdPointIndex
          let triPointIndex =
                case pointIndexState of
                  DormantPointIndex residentIndex -> residentIndex
                  ActivePersistentPointIndex residentIndex -> residentIndex
                  ActiveBatchPointIndex _ -> buildPointIndex triPointX triPointY
                  MissingPointIndex -> buildPointIndex triPointX triPointY
          triVertexOut <- freezePaged vertices mdVertexOut
          triHalfTopology <- freezePaged (4 * halfEdges) mdHalfTopology
          triConstraint <- freezePaged (halfEdges `quot` 2) mdConstraint
          triFaceEdge <- freezePaged faces mdFaceEdge
          let triElementDefaults = mdElementDefaults
          pure (Right Triangulation{..})

pointCapacity :: MutableDcel s vertex directed undirected face -> Int
pointCapacity = mdPointCapacity
{-# INLINE pointCapacity #-}

halfEdgeCapacity :: MutableDcel s vertex directed undirected face -> Int
halfEdgeCapacity = mdHalfCapacity
{-# INLINE halfEdgeCapacity #-}

pointCount :: MutableDcel s vertex directed undirected face -> ST s Int
pointCount = readSTRef . mdPointCount
{-# INLINE pointCount #-}

connectedCount :: MutableDcel s vertex directed undirected face -> ST s Int
connectedCount = readSTRef . mdConnectedCount
{-# INLINE connectedCount #-}

directedEdgeCount :: MutableDcel s vertex directed undirected face -> ST s Int
directedEdgeCount = readSTRef . mdHalfCount
{-# INLINE directedEdgeCount #-}

faceCount :: MutableDcel s vertex directed undirected face -> ST s Int
faceCount = readSTRef . mdFaceCount
{-# INLINE faceCount #-}

pointAt :: MutableDcel s vertex directed undirected face -> Int -> ST s (Point)
pointAt MutableDcel{mdPointX, mdPointY} index =
  Point <$> readPaged mdPointX index <*> readPaged mdPointY index
{-# INLINE pointAt #-}

-- | Resolve a canonical site through the derived handle index, confirming
-- every hash candidate against the authoritative coordinate planes. A mesh
-- created from scratch derives the index only if a caller actually asks; a
-- thawed published mesh inherits its structurally shared index.
lookupPointVertex
  :: MutableDcel s vertex directed undirected face
  -> Point
  -> ST s (Maybe Int)
lookupPointVertex mutable@MutableDcel{mdPointIndex} rawPoint = do
  indexState <- readSTRef mdPointIndex
  case canonicalPoint rawPoint of
    Point x y ->
      case indexState of
        ActiveBatchPointIndex table ->
          lookupMutablePoint table (readPointX mutable) (readPointY mutable) x y
        ActivePersistentPointIndex residentIndex ->
          resolvePersistent x y residentIndex
        DormantPointIndex residentIndex -> do
          writeSTRef mdPointIndex (ActivePersistentPointIndex residentIndex)
          resolvePersistent x y residentIndex
        MissingPointIndex -> do
          derived <- deriveMutablePointIndex mutable
          writeSTRef mdPointIndex (ActivePersistentPointIndex derived)
          resolvePersistent x y derived
 where
  resolvePersistent x y pointIndex =
    foldM
      (confirmCandidate mutable x y)
      Nothing
      (pointIndexCandidates x y pointIndex)

-- | Whether the transaction has already committed to incremental identity
-- transport. Answering does not force a dormant index's lazy rebuild, which
-- is the point: a per-question caller must not buy a whole-mesh build.
identityIndexActive :: MutableDcel s vertex directed undirected face -> ST s Bool
identityIndexActive MutableDcel{mdPointIndex} = do
  indexState <- readSTRef mdPointIndex
  pure $ case indexState of
    ActivePersistentPointIndex _ -> True
    ActiveBatchPointIndex _ -> True
    _ -> False
{-# INLINE identityIndexActive #-}

-- | Declare that a singleton handle-keyed rewrite must transport the resident
-- immutable identity section strictly. Dense point-keyed removal uses
-- 'activateBatchPointIndex' instead, so it neither forces nor incrementally
-- allocates the published 'PointIndex'.
activatePointIndex
  :: MutableDcel s vertex directed undirected face
  -> ST s ()
activatePointIndex mutable@MutableDcel{mdPointIndex} = do
  indexState <- readSTRef mdPointIndex
  case indexState of
    ActivePersistentPointIndex _ -> pure ()
    ActiveBatchPointIndex _ -> pure ()
    DormantPointIndex residentIndex ->
      writeSTRef mdPointIndex (ActivePersistentPointIndex residentIndex)
    MissingPointIndex -> do
      derived <- deriveMutablePointIndex mutable
      writeSTRef mdPointIndex (ActivePersistentPointIndex derived)

-- | Open an identity section for one dense removal program. The table derives
-- only from coordinate authority, and its extent is deliberately narrower
-- than the surrounding session: publication returns to the lazy immutable
-- derivation instead of retaining a second mutable identity owner.
activateBatchPointIndex
  :: MutableDcel s vertex directed undirected face
  -> ST s (Either BuildError ())
activateBatchPointIndex mutable@MutableDcel{mdPointIndex} = do
  vertices <- pointCount mutable
  table <- newMutablePointIndex vertices
  seeded <-
    seedMutablePointIndex
      table
      vertices
      (readPointX mutable)
      (readPointY mutable)
  case seeded of
    Left failure -> pure (Left failure)
    Right () -> do
      writeSTRef mdPointIndex (ActiveBatchPointIndex table)
      pure (Right ())
-- | Close the batch-local identity section after its removal program. Its
-- contents cannot escape @ST@; marking the cache missing makes freeze glue a
-- lazy immutable derivation from the final coordinate arenas.
discardBatchPointIndex
  :: MutableDcel s vertex directed undirected face
  -> ST s ()
discardBatchPointIndex MutableDcel{mdPointIndex} =
  modifySTRef'
    mdPointIndex
    (\indexState ->
       case indexState of
         ActiveBatchPointIndex _ -> MissingPointIndex
         retained -> retained
    )

deriveMutablePointIndex
  :: MutableDcel s vertex directed undirected face
  -> ST s PointIndex
deriveMutablePointIndex mutable = do
  vertices <- pointCount mutable
  foldM insertResident emptyPointIndex [0 .. vertices - 1]
 where
  insertResident pointIndex vertex = do
    x <- readPointX mutable vertex
    y <- readPointY mutable vertex
    pure (insertPointIndex x y vertex pointIndex)

confirmCandidate
  :: MutableDcel s vertex directed undirected face
  -> Double
  -> Double
  -> Maybe Int
  -> Int
  -> ST s (Maybe Int)
confirmCandidate _ _ _ resident@(Just _) _ = pure resident
confirmCandidate mutable x y Nothing candidate = do
  heldX <- readPointX mutable candidate
  heldY <- readPointY mutable candidate
  pure (if heldX == x && heldY == y then Just candidate else Nothing)
{-# INLINE confirmCandidate #-}

-- | Read one stored coordinate without building a t'Point'. Coordinates are
-- the authoritative state owned by 'mdPointX'/'mdPointY'; the t'Point'
-- constructor is the cold accessor's packaging, and the construction kernel
-- reads these arenas directly so a specialized sweep never boxes one.
readPointX :: MutableDcel s vertex directed undirected face -> Int -> ST s Double
readPointX MutableDcel{mdPointX} index = readPaged mdPointX index
{-# INLINE readPointX #-}

readPointY :: MutableDcel s vertex directed undirected face -> Int -> ST s Double
readPointY MutableDcel{mdPointY} index = readPaged mdPointY index
{-# INLINE readPointY #-}

writePoint :: MutableDcel s vertex directed undirected face -> Int -> Point -> ST s ()
writePoint MutableDcel{mdPointX, mdPointY} index rawPoint =
  case canonicalPoint rawPoint of
    Point x y -> do
      writePaged mdPointX index x
      writePaged mdPointY index y
{-# INLINE writePoint #-}

vertexDataAt :: MutableDcel s vertex directed undirected face -> Int -> ST s vertex
vertexDataAt MutableDcel{mdVertexData} = readBoxedPaged mdVertexData
{-# INLINE vertexDataAt #-}

writeVertexData :: MutableDcel s vertex directed undirected face -> Int -> vertex -> ST s ()
writeVertexData MutableDcel{mdVertexData} = writeBoxedPaged mdVertexData
{-# INLINE writeVertexData #-}

-- | Whether no element payload plane can be holding anything. Constant for the
-- transaction: see 'mdPayloadsPristine'. A rewrite site that performs several
-- resets together tests this once rather than paying the test inside each.
payloadsPristine :: MutableDcel s vertex directed undirected face -> Bool
payloadsPristine = mdPayloadsPristine
{-# INLINE payloadsPristine #-}

-- | Return one undirected edge and both its half-edges to the element
-- defaults. A payload labels the element occupying a slot, and an element is
-- its geometry: a rewrite that gives a slot new endpoints has put a different
-- edge there, and the label the old one carried does not describe it. Leaving
-- it would also make the payload plane depend on the flip order that reached
-- the normal form, while the topology does not.
--
-- The constraint flag is deliberately not reset with it. A flag states that a
-- segment of the input is present, and a segment that gets split is still
-- present as its two halves; a payload states what an element is.
resetEdgeData :: MutableDcel s vertex directed undirected face -> Int -> ST s ()
resetEdgeData MutableDcel{mdDirectedData, mdUndirectedData, mdPayloadsPristine, mdElementDefaults} pair =
  unless mdPayloadsPristine $ do
    resetBoxedRange mdDirectedData (defaultDirectedEdgeData mdElementDefaults) (2 * pair) 2
    resetBoxedRange mdUndirectedData (defaultUndirectedEdgeData mdElementDefaults) pair 1
{-# INLINE resetEdgeData #-}

-- | Return one face to the element default. See 'resetEdgeData'.
resetFaceData :: MutableDcel s vertex directed undirected face -> Int -> ST s ()
resetFaceData MutableDcel{mdFaceData, mdPayloadsPristine, mdElementDefaults} face =
  unless mdPayloadsPristine (resetBoxedRange mdFaceData (defaultFaceData mdElementDefaults) face 1)
{-# INLINE resetFaceData #-}

edgeOriginPoint :: MutableDcel s vertex directed undirected face -> Int -> ST s (Point)
edgeOriginPoint mutable edge = readOrigin mutable edge >>= pointAt mutable
{-# INLINE edgeOriginPoint #-}

appendVertex
  :: MutableDcel s vertex directed undirected face
  -> Point
  -> vertex
  -> ST s Int
appendVertex mutable rawPoint vertexData =
  case canonicalPoint rawPoint of
    Point x y -> appendVertexCoordinates mutable x y vertexData
{-# INLINE appendVertex #-}

-- | Append a vertex whose coordinates are already canonical, by components.
-- This is the one owner of the append record; 'appendVertex' is its
-- t'Point'-carrying form for callers holding a point. Raw capacity means the
-- appender initializes every field of the record it exposes.
appendVertexCoordinates
  :: MutableDcel s vertex directed undirected face
  -> Double
  -> Double
  -> vertex
  -> ST s Int
appendVertexCoordinates mutable@MutableDcel{mdPointCount, mdPointX, mdPointY, mdPointIndex, mdNewConnected, mdRecycledNew} x y vertexData = do
  vertex <- readSTRef mdPointCount
  writePaged mdPointX vertex x
  writePaged mdPointY vertex y
  writeVertexData mutable vertex vertexData
  writeVertexOut mutable vertex (-1)
  if vertex >= mdInitialPointCount mutable
    then writePaged mdNewConnected (vertex - mdInitialPointCount mutable) 0
    else modifySTRef' mdRecycledNew (IntSet.insert vertex)
  modifySTRef'
    mdPointIndex
    (\pointIndexState ->
       case pointIndexState of
         ActivePersistentPointIndex pointIndex ->
           ActivePersistentPointIndex (insertPointIndex x y vertex pointIndex)
         -- The batch table is only lawful over the removal subprogram that
         -- opened it. An insertion before that scope is closed invalidates the
         -- derived cache rather than pretending an unregistered handle exists.
         ActiveBatchPointIndex _ -> MissingPointIndex
         -- Transported lazily: the field holds a pure update thunk, so a batch
         -- that never asks an identity question pays one allocation per append,
         -- while a persistent chain that asks every publication forces a
         -- depth-one thunk instead of rebuilding the index over the whole mesh.
         DormantPointIndex pointIndex ->
           DormantPointIndex (insertPointIndex x y vertex pointIndex)
         MissingPointIndex -> MissingPointIndex
    )
  writeSTRef mdPointCount (vertex + 1)
  pure vertex

-- | Check the point arena before a local rewrite materializes vertices. The
-- caller performs this before the first write, so refusal needs no rollback.
ensurePointCapacity
  :: MutableDcel s vertex directed undirected face
  -> Int
  -> ST s (Either BuildError ())
ensurePointCapacity MutableDcel{mdPointCount, mdPointCapacity} additional
  | additional < 0 = pure (Left (CapacityExceeded additional))
  | otherwise = do
      current <- readSTRef mdPointCount
      let !required = current + additional
      pure $
        if required > mdPointCapacity
          then Left (CapacityExceeded required)
          else Right ()
{-# INLINE ensurePointCapacity #-}

markConnected :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()
markConnected mutable@MutableDcel{mdInitialPointCount, mdNewConnected, mdRecycledNew, mdConnectedCount} vertex outgoing = do
  if vertex >= mdInitialPointCount
    then do
      let !newVertex = vertex - mdInitialPointCount
      connected <- readPaged mdNewConnected newVertex
      unless (connected /= 0) $ do
        writePaged mdNewConnected newVertex 1
        modifySTRef' mdConnectedCount (+ 1)
    else do
      recycled <- readSTRef mdRecycledNew
      when (IntSet.member vertex recycled) $ do
        writeSTRef mdRecycledNew (IntSet.delete vertex recycled)
        modifySTRef' mdConnectedCount (+ 1)
  writeVertexOut mutable vertex outgoing
{-# INLINE markConnected #-}

isConnected :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool
isConnected MutableDcel{mdInitialPointCount, mdNewConnected, mdRecycledNew} vertex
  | vertex < mdInitialPointCount = IntSet.notMember vertex <$> readSTRef mdRecycledNew
  | otherwise = (/= 0) <$> readPaged mdNewConnected (vertex - mdInitialPointCount)
{-# INLINE isConnected #-}

addEdge :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s (Int, Int)
addEdge mutable from to = do
  base <- addEdgeBlock mutable 1
  writeOrigin mutable base from
  writeOrigin mutable (base + 1) to
  pure (base, base + 1)
{-# INLINE addEdge #-}

-- Each appended pair owns the initialization of its exposed topology and
-- constraint records; reserved capacity remains untouched.
addEdgeBlock :: MutableDcel s vertex directed undirected face -> Int -> ST s Int
addEdgeBlock mutable@MutableDcel{mdHalfCount, mdConstraint} pairs = do
  base <- readSTRef mdHalfCount
  let !required = base + 2 * pairs
      !firstUndirected = base `quot` 2
      !lastUndirected = firstUndirected + pairs - 1
  forM_ [4 * base .. 4 * required - 1] $ \slot ->
    writePaged (mdHalfTopology mutable) slot noIndex
  forM_ [firstUndirected .. lastUndirected] $ \edge -> writePaged mdConstraint edge 0
  writeSTRef mdHalfCount required
  pure base
{-# INLINE addEdgeBlock #-}

addFace :: MutableDcel s vertex directed undirected face -> Int -> ST s Int
addFace mutable anchor = do
  base <- addFaceBlock mutable 1
  writeFaceEdge mutable base anchor
  pure base
{-# INLINE addFace #-}

addFaceBlock :: MutableDcel s vertex directed undirected face -> Int -> ST s Int
addFaceBlock mutable@MutableDcel{mdFaceCount} count = do
  base <- readSTRef mdFaceCount
  let !required = base + count
  mapM_ (\face -> writeFaceEdge mutable face (-1)) [base .. required - 1]
  writeSTRef mdFaceCount required
  pure base
{-# INLINE addFaceBlock #-}

-- | Check the local allocation section before any topology rewrite begins.
-- A refusal leaves every mutable plane untouched, so the enclosing transaction
-- can abandon publication without rollback machinery.
ensureCellCapacity
  :: MutableDcel s vertex directed undirected face
  -> Int
  -> Int
  -> ST s (Either BuildError ())
ensureCellCapacity MutableDcel{mdHalfCount, mdHalfCapacity, mdFaceCount, mdFaceCapacity} additionalPairs additionalFaces
  | additionalPairs < 0 = pure (Left (HalfEdgeCapacityExceeded additionalPairs mdHalfCapacity))
  | additionalFaces < 0 = pure (Left (FaceCapacityExceeded additionalFaces mdFaceCapacity))
  | otherwise = do
      currentHalfEdges <- readSTRef mdHalfCount
      currentFaces <- readSTRef mdFaceCount
      let !requiredHalfEdges = currentHalfEdges + 2 * additionalPairs
          !requiredFaces = currentFaces + additionalFaces
      if requiredHalfEdges > mdHalfCapacity
        then pure (Left (HalfEdgeCapacityExceeded requiredHalfEdges mdHalfCapacity))
        else
          if requiredFaces > mdFaceCapacity
            then pure (Left (FaceCapacityExceeded requiredFaces mdFaceCapacity))
            else pure (Right ())
{-# INLINE ensureCellCapacity #-}

truncatePoints :: MutableDcel s vertex directed undirected face -> Int -> ST s ()
truncatePoints MutableDcel{mdPointCount, mdConnectedCount} count = do
  writeSTRef mdPointCount count
  connected <- readSTRef mdConnectedCount
  when (connected > count) (writeSTRef mdConnectedCount count)

truncateDirectedEdges :: MutableDcel s vertex directed undirected face -> Int -> ST s ()
truncateDirectedEdges MutableDcel{mdHalfCount} = writeSTRef mdHalfCount

truncateFaces :: MutableDcel s vertex directed undirected face -> Int -> ST s ()
truncateFaces MutableDcel{mdFaceCount, mdLastFace} count = do
  writeSTRef mdFaceCount count
  lastFace <- readSTRef mdLastFace
  when (lastFace >= count) (writeSTRef mdLastFace (if count > 1 then 1 else 0))

-- | Remove one undirected edge by moving the last pair into its slot. Only the
-- two neighboring links, one vertex representative, and one face
-- representative per moved half-edge can reference the old handles.
--
-- The slot the tail vacates is returned to the defaults here rather than when
-- the allocator hands it back out. That keeps one invariant — every slot at or
-- above the live count holds the fill — which the thaw establishes, this
-- preserves, and 'addEdgeBlock' may therefore assume without testing anything.
-- The cost lands on removal, which is where the element was retired, instead of
-- on every allocation a pure insertion makes.
swapRemoveUndirectedEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ())
swapRemoveUndirectedEdge mutable@MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} pair = do
  halfEdges <- directedEdgeCount mutable
  let !pairs = halfEdges `quot` 2
      !lastPair = pairs - 1
  if pair < 0 || pair > lastPair
    then
      pure
        ( Left
            ( RemovalEdgeOutOfRange
                (UndirectedEdgeId (fromIntegral pair))
                pairs
            )
        )
    else do
      swapRemoveUndirectedEdgeInRange lastPair
      pure (Right ())
 where
  swapRemoveUndirectedEdgeInRange lastPair = do
    removedFlag <- readPaged mdConstraint pair
    lastFlag <- readPaged mdConstraint lastPair
    when (removedFlag /= 0) (modifySTRef' mdConstraintCount (subtract 1))
    when (pair /= lastPair) $ do
      let !oldBase = 2 * lastPair
          !newBase = 2 * pair
          remap !handle
            | handle == oldBase = newBase
            | handle == oldBase + 1 = newBase + 1
            | otherwise = handle
      -- Both records are taken before either is republished: the pair's two
      -- half-edges can name each other, so a read after the first write would
      -- see the new handle where the old one belongs.
      !forwardOrigin <- readOrigin mutable oldBase
      !forwardNext <- remap <$> readNext mutable oldBase
      !forwardPrevious <- remap <$> readPrevious mutable oldBase
      !forwardFace <- readFace mutable oldBase
      !backwardOrigin <- readOrigin mutable (oldBase + 1)
      !backwardNext <- remap <$> readNext mutable (oldBase + 1)
      !backwardPrevious <- remap <$> readPrevious mutable (oldBase + 1)
      !backwardFace <- readFace mutable (oldBase + 1)
      writePaged mdConstraint pair lastFlag
      unless (mdPayloadsPristine mutable) $ do
        readBoxedPaged (mdUndirectedData mutable) lastPair >>= writeBoxedPaged (mdUndirectedData mutable) pair
        readBoxedPaged (mdDirectedData mutable) oldBase >>= writeBoxedPaged (mdDirectedData mutable) newBase
        readBoxedPaged (mdDirectedData mutable) (oldBase + 1) >>= writeBoxedPaged (mdDirectedData mutable) (newBase + 1)
      writeOrigin mutable newBase forwardOrigin
      writeNext mutable newBase forwardNext
      writePrevious mutable newBase forwardPrevious
      writeFace mutable newBase forwardFace
      writeOrigin mutable (newBase + 1) backwardOrigin
      writeNext mutable (newBase + 1) backwardNext
      writePrevious mutable (newBase + 1) backwardPrevious
      writeFace mutable (newBase + 1) backwardFace
      writeNext mutable forwardPrevious newBase
      writePrevious mutable forwardNext newBase
      writeVertexOut mutable forwardOrigin newBase
      writeFaceEdge mutable forwardFace newBase
      writeNext mutable backwardPrevious (newBase + 1)
      writePrevious mutable backwardNext (newBase + 1)
      writeVertexOut mutable backwardOrigin (newBase + 1)
      writeFaceEdge mutable backwardFace (newBase + 1)
    modifySTRef'
      mdConstraintEdges
      (\edges ->
         let withoutRetired = IntSet.delete pair (IntSet.delete lastPair edges)
          in if pair /= lastPair && lastFlag /= 0
               then IntSet.insert pair withoutRetired
               else withoutRetired
      )
    resetEdgeData mutable lastPair
    truncateDirectedEdges mutable (2 * lastPair)

swapRemoveFace :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ())
swapRemoveFace mutable face = do
  faces <- faceCount mutable
  let !lastFace = faces - 1
  if face <= 0 || face > lastFace
    then
      pure
        ( Left
            (RemovalFaceOutOfRange (FaceId (fromIntegral face)) faces)
        )
    else do
      relocated <-
        if face == lastFace
          then pure (Right ())
          else relocateLastFace lastFace
      case relocated of
        Left obstruction -> pure (Left obstruction)
        Right () -> do
          resetFaceData mutable lastFace
          truncateFaces mutable lastFace
          pure (Right ())
 where
  relocateLastFace lastFace = do
    start <- readFaceEdge mutable lastFace
    writeFaceEdge mutable face start
    -- Swap-compaction moves the last face's index, not the face. When the
    -- locator's cached start is that face, following it here is the difference
    -- between a batch of removals resuming where the previous one settled and
    -- 'truncateFaces' finding the cached index out of range and resetting it to
    -- the first inner face. The cache is a start, never an answer.
    cachedFace <- readSTRef (mdLastFace mutable)
    when (cachedFace == lastFace) (writeSTRef (mdLastFace mutable) face)
    unless (mdPayloadsPristine mutable) $
      readBoxedPaged (mdFaceData mutable) lastFace >>= writeBoxedPaged (mdFaceData mutable) face
    halfEdges <- directedEdgeCount mutable
    let go !remaining !current !seen
          | remaining <= 0 =
              pure
                ( Left
                    ( RemovalFaceCycleDidNotTerminate
                        (FaceId (fromIntegral lastFace))
                        (DirectedEdgeId (fromIntegral current))
                        (halfEdges + 1)
                    )
                )
          | seen && current == start = pure (Right ())
          | otherwise = do
              writeFace mutable current face
              nextEdge <- readNext mutable current
              go (remaining - 1) nextEdge True
    go (halfEdges + 1) start False

-- | Retire a vertex by moving the arena's last into its slot. The relocation is
-- reported as the slot together with the position now standing in it: the two
-- are one fact, and a caller told only the slot has to consult the mesh to
-- learn what landed there.
swapRemoveVertex :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))
swapRemoveVertex mutable@MutableDcel{mdConnectedCount, mdPointIndex, mdRecycledNew, mdNewConnected} vertex = do
  vertices <- pointCount mutable
  let !lastVertex = vertices - 1
  if vertex < 0 || vertex > lastVertex
    then
      pure
        ( Left
            (RemovalVertexOutOfRange (VertexId (fromIntegral vertex)) vertices)
        )
    else swapRemoveVertexInRange lastVertex
 where
  swapRemoveVertexInRange lastVertex = do
    removedPoint <- pointAt mutable vertex
    removedPayload <- vertexDataAt mutable vertex
    movedOutcome <-
      if vertex == lastVertex
        then pure (Right Nothing)
        else moveTailVertex lastVertex
    case movedOutcome of
      Left obstruction -> pure (Left obstruction)
      Right moved -> do
        indexState <- readSTRef mdPointIndex
        updatedIndexState <-
          updatePointIndexAfterSwap mutable indexState removedPoint vertex lastVertex moved
        writeSTRef mdPointIndex updatedIndexState
        -- The connectivity companions must agree with the aggregate assertion two
        -- lines down: after a swap removal every surviving vertex is connected. The
        -- retired slot's entry and the relocated occupant's old entry are both
        -- stale, and a relocated occupant landing in the appended region must read
        -- connected through the offset store, not through its predecessor's bit.
        modifySTRef' mdRecycledNew (IntSet.delete vertex . IntSet.delete lastVertex)
        case moved of
          Just _
            | vertex >= mdInitialPointCount mutable ->
                writePaged mdNewConnected (vertex - mdInitialPointCount mutable) 1
          _ -> pure ()
        truncatePoints mutable lastVertex
        writeSTRef mdConnectedCount lastVertex
        pure (Right (removedPoint, removedPayload, moved))

  moveTailVertex lastVertex = do
    movedPoint <- pointAt mutable lastVertex
    movedPayload <- vertexDataAt mutable lastVertex
    movedOut <- readVertexOut mutable lastVertex
    writePoint mutable vertex movedPoint
    writeVertexData mutable vertex movedPayload
    writeVertexOut mutable vertex movedOut
    relocated <-
      if movedOut < 0
        then pure (Right ())
        else relocateOutgoingCycle lastVertex movedOut
    pure (Just (vertex, movedPoint) <$ relocated)

  relocateOutgoingCycle lastVertex movedOut = do
    halfEdges <- directedEdgeCount mutable
    let go !remaining !current !seen
          | remaining <= 0 =
              pure
                ( Left
                    ( RemovalOutgoingCycleDidNotTerminate
                        (VertexId (fromIntegral lastVertex))
                        (DirectedEdgeId (fromIntegral current))
                        (halfEdges + 1)
                    )
                )
          | seen && current == movedOut = pure (Right ())
          | otherwise = do
              writeOrigin mutable current vertex
              previousEdge <- readPrevious mutable current
              go (remaining - 1) (previousEdge `xor` 1) True
    go (halfEdges + 1) movedOut False

-- | Transport the identity view across one vertex swap. Persistent sections
-- retain their existing pure update law. A batch table mutates in place, then
-- deliberately falls back to @MissingPointIndex@ if either local proof cannot
-- be completed; geometry remains authoritative and subsequent operations walk
-- rather than observe a stale cache.
updatePointIndexAfterSwap
  :: MutableDcel s vertex directed undirected face
  -> MutablePointIndexState s
  -> Point
  -> Int
  -> Int
  -> Maybe (Int, Point)
  -> ST s (MutablePointIndexState s)
updatePointIndexAfterSwap mutable indexState removedPoint vertex lastVertex moved =
  case indexState of
    DormantPointIndex pointIndex ->
      pure (DormantPointIndex (updatePersistentPointIndex pointIndex))
    ActivePersistentPointIndex pointIndex ->
      pure (ActivePersistentPointIndex (updatePersistentPointIndex pointIndex))
    ActiveBatchPointIndex table ->
      transportBatchPointIndex table
    MissingPointIndex -> pure MissingPointIndex
 where
  updatePersistentPointIndex pointIndex =
    case removedPoint of
      Point removedX removedY ->
        let withoutRemoved = removePointIndex removedX removedY vertex pointIndex
         in case moved of
              Nothing -> withoutRemoved
              Just (_, Point movedX movedY) ->
                relocatePointIndex movedX movedY lastVertex vertex withoutRemoved

  transportBatchPointIndex table =
    case removedPoint of
      Point removedX removedY -> do
        removed <-
          removeMutablePoint
            table
            (readPointX mutable)
            (readPointY mutable)
            removedX
            removedY
            vertex
        case (removed, moved) of
          (MutablePointIndexUpdated, Nothing) ->
            pure (ActiveBatchPointIndex table)
          (MutablePointIndexUpdated, Just (_, Point movedX movedY)) -> do
            relocated <- relocateMutablePoint table movedX movedY lastVertex vertex
            pure $
              case relocated of
                MutablePointIndexUpdated -> ActiveBatchPointIndex table
                MutablePointIndexInvalidated -> MissingPointIndex
          (MutablePointIndexInvalidated, _) -> pure MissingPointIndex

  -- 'swapRemoveVertex' calls us before truncation. The tail's coordinate cells
  -- still carry the moved point, so backward-shift repair can derive every
  -- occupant home from the same canonical storage that the table indexes.
linkEdges :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()
linkEdges mutable left right = do
  writeNext mutable left right
  writePrevious mutable right left
{-# INLINE linkEdges #-}

setCycle3 :: MutableDcel s vertex directed undirected face -> Int -> Int -> Int -> Int -> ST s ()
setCycle3 mutable face e0 e1 e2 = do
  writeNext mutable e0 e1
  writeNext mutable e1 e2
  writeNext mutable e2 e0
  writePrevious mutable e0 e2
  writePrevious mutable e1 e0
  writePrevious mutable e2 e1
  writeFace mutable e0 face
  writeFace mutable e1 face
  writeFace mutable e2 face
  writeFaceEdge mutable face e0
{-# INLINE setCycle3 #-}

faceEdges :: MutableDcel s vertex directed undirected face -> Int -> ST s (Int, Int, Int)
faceEdges mutable face = do
  e0 <- readFaceEdge mutable face
  e1 <- readNext mutable e0
  e2 <- readNext mutable e1
  pure (e0, e1, e2)
{-# INLINE faceEdges #-}

readOrigin :: MutableDcel s vertex directed undirected face -> Int -> ST s Int
readOrigin MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index)
readNext :: MutableDcel s vertex directed undirected face -> Int -> ST s Int
readNext MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index + 1)
readPrevious :: MutableDcel s vertex directed undirected face -> Int -> ST s Int
readPrevious MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index + 2)
readFace :: MutableDcel s vertex directed undirected face -> Int -> ST s Int
readFace MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index + 3)
{-# INLINE readOrigin #-}
{-# INLINE readNext #-}
{-# INLINE readPrevious #-}
{-# INLINE readFace #-}

writeOrigin :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()
writeOrigin MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index) (packIndex value)
writeNext :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()
writeNext MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 1) (packIndex value)
writePrevious :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()
writePrevious MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 2) (packIndex value)
writeFace :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()
writeFace MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 3) (packIndex value)
{-# INLINE writeOrigin #-}
{-# INLINE writeNext #-}
{-# INLINE writePrevious #-}
{-# INLINE writeFace #-}

readVertexOut :: MutableDcel s vertex directed undirected face -> Int -> ST s Int
readVertexOut MutableDcel{mdVertexOut} index = do
  value <- readPaged mdVertexOut index
  pure (if value == noIndex then -1 else fromIntegral value)
{-# INLINE readVertexOut #-}

writeVertexOut :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()
writeVertexOut MutableDcel{mdVertexOut} index value =
  writePaged mdVertexOut index (if value < 0 then noIndex else packIndex value)
{-# INLINE writeVertexOut #-}

readFaceEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s Int
readFaceEdge MutableDcel{mdFaceEdge} index = do
  value <- readPaged mdFaceEdge index
  pure (if value == noIndex then -1 else fromIntegral value)
{-# INLINE readFaceEdge #-}

writeFaceEdge :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()
writeFaceEdge MutableDcel{mdFaceEdge} index value =
  writePaged mdFaceEdge index (if value < 0 then noIndex else packIndex value)
{-# INLINE writeFaceEdge #-}

readConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool
readConstraint MutableDcel{mdConstraint} directed = (/= 0) <$> readPaged mdConstraint (directed `quot` 2)
{-# INLINE readConstraint #-}

setConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool
setConstraint MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} directed = do
  let !index = directed `quot` 2
  current <- readPaged mdConstraint index
  if current /= 0
    then pure False
    else do
      writePaged mdConstraint index 1
      modifySTRef' mdConstraintCount (+ 1)
      modifySTRef' mdConstraintEdges (IntSet.insert index)
      pure True
{-# INLINE setConstraint #-}

clearConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool
clearConstraint MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} directed = do
  let !index = directed `quot` 2
  current <- readPaged mdConstraint index
  if current == 0
    then pure False
    else do
      writePaged mdConstraint index 0
      modifySTRef' mdConstraintCount (subtract 1)
      modifySTRef' mdConstraintEdges (IntSet.delete index)
      pure True
{-# INLINE clearConstraint #-}