CandidateArena.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | The legalization candidate stack: tagging, growth, and seeding.
module Moonlight.Triangulation.Internal.DcelOperations.CandidateArena
  ( starCandidate
  , genericCandidate
  , growLegalizationArena
  , seedStarScratch
  , seedGenericEdges
  , noStarVertex
  ) where

import Control.Monad (forM_, when)
import Control.Monad.ST (ST)
import Data.Word (Word32)
import qualified Data.Vector.Unboxed.Mutable as MUV
import Moonlight.Triangulation.Internal.OperationState
  ( OperationState
  , legalizationArena
  , readScratch
  , storeLegalizationArena
  )
import Moonlight.Triangulation.Internal.PackedIndex (packIndex)

-- A candidate carries the discipline under which it must be tested. One
-- seeded from an insertion star names an edge that has to be re-oriented so
-- the inserted vertex is opposite it; one seeded generically already names the
-- edge to test. Building a geometric patch used to start and drain the work
-- stack once per primitive because the two could not share it — the fan, then
-- every closed hull turn separately, each re-reading the same neighbourhood.
-- With the discipline travelling on the candidate they share one drain.
starCandidate :: Int -> Int
starCandidate edge = edge * 2
{-# INLINE starCandidate #-}

genericCandidate :: Int -> Int
genericCandidate edge = edge * 2 + 1
{-# INLINE genericCandidate #-}

-- | Seed candidates from the scratch arena, returning the new stack top.
-- Transaction-sized preallocation covers the normal path; rare adversarial
-- overflow grows the operation-owned vector without changing LIFO order.
seedStarScratch :: OperationState s -> Int -> Int -> ST s Int
seedStarScratch operation top candidateCount = do
  initialArena <- legalizationArena operation
  arena <- growLegalizationArena initialArena (top + candidateCount)
  when (MUV.length arena /= MUV.length initialArena) (storeLegalizationArena operation arena)
  forM_ [0 .. candidateCount - 1] $ \index -> do
    edge <- readScratch operation index
    MUV.unsafeWrite arena (top + index) (packIndex (starCandidate edge))
  pure (top + candidateCount)

-- | Seed generic candidates from a list, returning the new stack top.
seedGenericEdges :: OperationState s -> Int -> [Int] -> ST s Int
seedGenericEdges operation top edges = do
  initialArena <- legalizationArena operation
  let !count = length edges
  arena <- growLegalizationArena initialArena (top + count)
  when (MUV.length arena /= MUV.length initialArena) (storeLegalizationArena operation arena)
  forM_ (zip [0 ..] edges) $ \(!index, !edge) ->
    MUV.unsafeWrite arena (top + index) (packIndex (genericCandidate edge))
  pure (top + count)

growLegalizationArena :: MUV.MVector s Word32 -> Int -> ST s (MUV.MVector s Word32)
growLegalizationArena arena required
  | required <= current = pure arena
  | otherwise = MUV.grow arena (max (required - current) (max 1 current))
 where
  !current = MUV.length arena
{-# INLINE growLegalizationArena #-}

-- | No star candidate can be seeded against this, so a drain given it must
-- have been seeded generically throughout.
noStarVertex :: Int
noStarVertex = -1