Hull.hs

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

-- | Growth outside the hull: visible ranges, turn closure, and convexity repair.
module Moonlight.Triangulation.Internal.DcelOperations.Hull
  ( insertOutsideHull
  , insertOutsideHullBetween
  , closeOuterTurn
  , fixHullConvexity
  ) where

import Control.Monad (forM_)
import Control.Monad.ST (ST)
import Data.STRef (writeSTRef)
import Moonlight.Triangulation.Handles.HandleDefs (DirectedEdgeId (..), FaceId (..))
import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena
  ( noStarVertex
  , seedGenericEdges
  )
import Moonlight.Triangulation.Internal.DcelOperations.FlipRule (LegalizationLaw (..))
import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeScratch)
import Moonlight.Triangulation.Internal.DcelOperations.Normalize (drainLegalization)
import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)
import Moonlight.Triangulation.Internal.Mutable
  ( MutableDcel (..)
  , addEdge
  , addEdgeBlock
  , addFaceBlock
  , directedEdgeCount
  , ensureCellCapacity
  , linkEdges
  , markConnected
  , pointAt
  , readFace
  , readFaceEdge
  , readNext
  , readOrigin
  , readPointX
  , readPointY
  , readPrevious
  , setCycle3
  , writeFace
  , writeFaceEdge
  , writeOrigin
  , writeVertexOut
  )
import Moonlight.Triangulation.Internal.OperationState
  ( Counter (..)
  , OperationState
  , addCounter
  , readScratch
  , writeScratch
  )
import Moonlight.Triangulation.Internal.Probe (KnownProbe)
import Moonlight.Triangulation.Types (BuildError (..), Point (..))
import Moonlight.Triangulation.Scalar (orient2dCoordinates)

insertOutsideHull :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())
insertOutsideHull mutable operation start vertex = do
  query <- pointAt mutable vertex
  visibleStart <- visibleOuter mutable start query
  if not visibleStart
    then pure (Left (HullStartNotVisible (DirectedEdgeId (fromIntegral start))))
    else do
      halfEdges <- directedEdgeCount mutable
      left <- expandPrevious halfEdges start start query
      right <- expandNext halfEdges start left query
      collected <- collectOuterChain mutable operation left right
      case collected of
        Left obstruction -> pure (Left obstruction)
        Right chainCount -> do
          inserted <- insertOutsideHullCollected @p mutable operation vertex chainCount
          case inserted of
            Left obstruction -> pure (Left obstruction)
            Right _ -> do
              -- The regular insertion path owns its own hull-insertion count; the sweep
              -- path through 'insertOutsideHullBetween' counts its own instead.
              addCounter operation CounterHullInsertions 1
              pure (Right ())
 where
  expandPrevious !bound !stopAt !current !query
    | bound <= 0 = pure current
    | otherwise = do
        candidate <- readPrevious mutable current
        if candidate == stopAt
          then pure current
          else do
            visible <- visibleOuter mutable candidate query
            if visible then expandPrevious (bound - 1) stopAt candidate query else pure current

  expandNext !bound !current !left !query
    | bound <= 0 = pure current
    | otherwise = do
        candidate <- readNext mutable current
        if candidate == left
          then pure current
          else do
            visible <- visibleOuter mutable candidate query
            if visible then expandNext (bound - 1) candidate left query else pure current

-- | Insert a vertex outside an explicitly selected contiguous outer-face range.
-- The range, rather than a convexity policy, is the primitive: regular
-- insertion supplies the complete visible range, while circle sweep may supply
-- one edge and defer the remaining hull turns. Topology mutation has one owner.
insertOutsideHullBetween
  :: forall p s vertex directed undirected face
   . KnownProbe p
  => MutableDcel s vertex directed undirected face
  -> OperationState s
  -> Int
  -> Int
  -> Int
  -> ST s (Either BuildError (Int, Int))
insertOutsideHullBetween mutable operation left right vertex = do
  collected <- collectOuterChain mutable operation left right
  case collected of
    Left obstruction -> pure (Left obstruction)
    Right chainCount -> insertOutsideHullCollected @p mutable operation vertex chainCount

collectOuterChain
  :: MutableDcel s vertex directed undirected face
  -> OperationState s
  -> Int
  -> Int
  -> ST s (Either BuildError Int)
collectOuterChain mutable operation left right = do
  halfEdges <- directedEdgeCount mutable
  go (halfEdges + 1) left 0
 where
  go !remaining !current !count
    | remaining <= 0 =
        pure
          ( Left
              ( OuterRangeDidNotTerminate
                  (DirectedEdgeId (fromIntegral left))
                  (DirectedEdgeId (fromIntegral right))
                  count
              )
          )
    | otherwise = do
        incident <- readFace mutable current
        if incident /= 0
          then
            pure
              ( Left
                  ( OuterRangeContainsInnerEdge
                      (DirectedEdgeId (fromIntegral current))
                      (FaceId (fromIntegral incident))
                  )
              )
          else do
            writeScratch operation count current
            if current == right
              then pure (Right (count + 1))
              else readNext mutable current >>= \following -> go (remaining - 1) following (count + 1)

insertOutsideHullCollected
  :: forall p s vertex directed undirected face
   . KnownProbe p
  => MutableDcel s vertex directed undirected face
  -> OperationState s
  -> Int
  -> Int
  -> ST s (Either BuildError (Int, Int))
insertOutsideHullCollected mutable@MutableDcel{mdLastFace} operation vertex chainCount = do
  capacity <- ensureCellCapacity mutable (chainCount + 1) chainCount
  case capacity of
    Left obstruction -> pure (Left obstruction)
    Right () -> Right <$> insertOutsideHullWithCapacity
 where
  insertOutsideHullWithCapacity = do
    left <- readScratch operation 0
    right <- readScratch operation (chainCount - 1)
    oldPrevious <- readPrevious mutable left
    oldNext <- readNext mutable right
    edgeBase <- addEdgeBlock mutable (chainCount + 1)
    faceBase <- addFaceBlock mutable chainCount
    forM_ [0 .. chainCount] $ \index -> do
      chainVertex <-
        if index == 0
          then readScratch operation 0 >>= readOrigin mutable
          else readScratch operation (index - 1) >>= readOrigin mutable . reverseIndex
      let !forward = edgeBase + 2 * index
          !backward = forward + 1
      writeOrigin mutable forward chainVertex
      writeOrigin mutable backward vertex
    forM_ [0 .. chainCount - 1] $ \index -> do
      outerEdge <- readScratch operation index
      let !face = faceBase + index
          !nextSpoke = edgeBase + 2 * (index + 1)
          !previousSpoke = edgeBase + 2 * index + 1
      setCycle3 mutable face outerEdge nextSpoke previousSpoke
    let !firstOuterSpoke = edgeBase
        !lastOuterSpoke = edgeBase + 2 * chainCount + 1
    writeFace mutable firstOuterSpoke 0
    writeFace mutable lastOuterSpoke 0
    linkEdges mutable oldPrevious firstOuterSpoke
    linkEdges mutable firstOuterSpoke lastOuterSpoke
    linkEdges mutable lastOuterSpoke oldNext
    writeFaceEdge mutable 0 firstOuterSpoke
    forM_ [0 .. chainCount - 1] $ \index -> do
      chainEdge <- readScratch operation index
      chainVertex <- readOrigin mutable chainEdge
      writeVertexOut mutable chainVertex chainEdge
    lastChain <- readScratch operation (chainCount - 1)
    lastVertex <- readOrigin mutable (reverseIndex lastChain)
    writeVertexOut mutable lastVertex (edgeBase + 2 * chainCount)
    markConnected mutable vertex lastOuterSpoke
    writeSTRef mdLastFace faceBase
    legalizeScratch @p mutable operation vertex chainCount
    pure (firstOuterSpoke, lastOuterSpoke)

-- | Replace two consecutive outer edges @a->b, b->c@ by @a->c@ and
-- materialize the triangle they bound. The returned edge is the new outer
-- diagonal. This is the sole turn-closing primitive used both by deferred
-- circle sweep and the final Graham repair. Topology mutation only: the
-- caller owns the legalization epoch, and seeds the two closed edges itself
-- once the replacement's links are in place.
closeOuterTurn
  :: MutableDcel s vertex directed undirected face
  -> Int
  -> ST s (Either BuildError Int)
closeOuterTurn mutable first = do
  capacity <- ensureCellCapacity mutable 1 1
  case capacity of
    Left obstruction -> pure (Left obstruction)
    Right () -> do
      second <- readNext mutable first
      oldPrevious <- readPrevious mutable first
      oldNext <- readNext mutable second
      from <- readOrigin mutable first
      to <- readOrigin mutable (reverseIndex second)
      (outer, inner) <- addEdge mutable from to
      newFace <- addFaceBlock mutable 1
      writeFace mutable outer 0
      setCycle3 mutable newFace first second inner
      linkEdges mutable oldPrevious outer
      linkEdges mutable outer oldNext
      writeFaceEdge mutable 0 outer
      writeVertexOut mutable from outer
      writeVertexOut mutable to inner
      pure (Right outer)
{-# INLINE closeOuterTurn #-}

-- | Close every remaining left turn of the star-shaped sweep hull in one
-- Graham-style pass. Each closure strictly decreases the outer-edge count, so
-- the pass is linear in the visited hull plus the local Delaunay legalization
-- work it causes. Turn closures are seeded into one shared epoch as they
-- happen and drained once at the end: closure never deletes an edge and never
-- touches the outer cycle's legality, so which turns close does not depend on
-- when the interior is repaired. The pass counts its own closures and returns
-- the drain's tallies; nothing is reported behind its back.
fixHullConvexity
  :: forall p s vertex directed undirected face
   . KnownProbe p
  => MutableDcel s vertex directed undirected face
  -> OperationState s
  -> ST s (Either BuildError (Int, Int, Int))
fixHullConvexity mutable operation = do
  start <- readFaceEdge mutable 0
  if start < 0
    then pure (Right (0, 0, 0))
    else do
      walked <- walk start start 0 0 0 0
      case walked of
        Left obstruction -> pure (Left obstruction)
        Right (top, closures) -> do
          (flips, maxDepth) <- drainLegalization @p mutable operation top noStarVertex ValidMesh
          pure (Right (closures, flips, maxDepth))
 where
  walk !start !current !stackSize !steps !top !closures = do
    halfEdges <- directedEdgeCount mutable
    if steps > halfEdges + 2
      then
        pure
          ( Left
              ( OuterCycleDidNotTerminate
                  (DirectedEdgeId (fromIntegral start))
                  (DirectedEdgeId (fromIntegral current))
                  steps
              )
          )
      else do
        following <- readNext mutable current
        writeScratch operation stackSize current
        reduction <- reduce (stackSize + 1) top closures
        case reduction of
          Left obstruction -> pure (Left obstruction)
          Right (reduced, nextTop, nextClosures) -> do
            finished <-
              if reduced < 2
                then pure False
                else (== following) <$> readScratch operation 1
            if finished
              then pure (Right (nextTop, nextClosures))
              else walk start following reduced (steps + 1) nextTop nextClosures

  reduce !count !top !closures
    | count < 2 = pure (Right (count, top, closures))
    | otherwise = do
        first <- readScratch operation (count - 2)
        second <- readScratch operation (count - 1)
        fromVertex <- readOrigin mutable first
        middleVertex <- readOrigin mutable (reverseIndex first)
        targetVertex <- readOrigin mutable (reverseIndex second)
        fromX <- readPointX mutable fromVertex
        fromY <- readPointY mutable fromVertex
        middleX <- readPointX mutable middleVertex
        middleY <- readPointY mutable middleVertex
        targetX <- readPointX mutable targetVertex
        targetY <- readPointY mutable targetVertex
        if orient2dCoordinates fromX fromY middleX middleY targetX targetY == GT
          then do
            closed <- closeOuterTurn mutable first
            case closed of
              Left obstruction -> pure (Left obstruction)
              Right replacement -> do
                writeScratch operation (count - 2) replacement
                nextTop <- seedGenericEdges operation top [first, second]
                reduce (count - 1) nextTop (closures + 1)
          else pure (Right (count, top, closures))

visibleOuter :: MutableDcel s vertex directed undirected face -> Int -> Point -> ST s Bool
visibleOuter mutable edge query = do
  fromVertex <- readOrigin mutable edge
  toVertex <- readOrigin mutable (reverseIndex edge)
  case query of
    Point queryX queryY -> do
      fromX <- readPointX mutable fromVertex
      fromY <- readPointY mutable fromVertex
      toX <- readPointX mutable toVertex
      toY <- readPointY mutable toVertex
      pure (orient2dCoordinates fromX fromY toX toY queryX queryY == GT)
{-# INLINE visibleOuter #-}