Segment.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}

-- | The singleton segment verbs: glue one segment or a polyline, and retire a
-- constraint, each inside one sealed transaction.
module Moonlight.Triangulation.Internal.Cdt.Segment
  ( addConstraintEdge
  , addConstraintEdges
  , applyConstraintToExistingEndpoints
  , applyAndPublishConstraint
  , publishConstraintResult
  , insertPolylineVertices
  , removeConstraintEdge
  , retireConstraintEdge
  ) where

import Control.Monad.ST (ST, runST)
import qualified Data.Vector as V
import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray)
import Moonlight.Triangulation.BulkLoad (insertMany)
import qualified Moonlight.Triangulation.Dcel as Dcel
import Moonlight.Triangulation.Handles.HandleDefs
import Moonlight.Triangulation.Internal.Capacity (ensureCapacity)
import Moonlight.Triangulation.Internal.Cdt.Admission
  ( ConstraintAdmission (..)
  , constraintAdmission
  )
import Moonlight.Triangulation.Internal.Cdt.Batch (recoverConstraints)
import Moonlight.Triangulation.Internal.Cdt.Combinators
  ( asConstraintStep
  , bindMutable
  , mapLeft
  )
import Moonlight.Triangulation.Internal.Cdt.Recovery (applyMutableConstraint)
import Moonlight.Triangulation.Internal.Cdt.Site
  ( lookupExistingConstraintEndpoint
  , placeConstraintEndpoint
  )
import Moonlight.Triangulation.Internal.Cdt.Types
import Moonlight.Triangulation.Internal.DcelOperations
import Moonlight.Triangulation.Internal.Growable
  ( GrowableWord32
  , newGrowableWord32
  )
import Moonlight.Triangulation.Internal.Mutable
import Moonlight.Triangulation.Internal.OperationState
  ( Counter (..)
  , OperationState
  , addCounter
  , newOperationState
  )
import Moonlight.Triangulation.Internal.Representation
import Moonlight.Triangulation.Internal.Types
import Moonlight.Triangulation.Math

-- | Site both endpoints and glue the segment between them, in one transaction.
-- A refused request publishes nothing, so the caller's triangulation still
-- stands and the endpoints it would have sited are not among its vertices.
addConstraintEdge
  :: HasPosition vertex
  => Triangulation 'Constrained vertex directed undirected face
  -> vertex
  -> vertex
  -> Either (CdtError) (ConstraintResult vertex directed undirected face)
addConstraintEdge triangulation fromVertex toVertex = do
  _ <- mapLeft CdtBuildError (validatePoint Nothing fromPoint)
  _ <- mapLeft CdtBuildError (validatePoint Nothing toPoint)
  result <-
    case
        ( lookupExistingConstraintEndpoint triangulation fromPoint
        , lookupExistingConstraintEndpoint triangulation toPoint
        ) of
      (Just from, Just to) ->
        case constraintAdmission triangulation from to of
          ConstraintBlocked blocking -> Left (ConstraintIntersection blocking)
          ConstraintAdmitted ->
            applyConstraintToExistingEndpoints
              triangulation
              from
              fromVertex
              to
              toVertex
      _ -> addConstraintWithEndpointPlacement
  pure result
 where
  !fromPoint = position fromVertex
  !toPoint = position toVertex
  -- Both endpoints may be new; neither may be. The reservation is for the peak.
  !capacity = Dcel.numVertices triangulation + 2

  addConstraintWithEndpointPlacement = do
    mapLeft CdtBuildError (ensureCapacity capacity)
    runST $ do
      mutable <- thawTriangulation capacity triangulation
      operation <- newOperationState (halfEdgeCapacity mutable)
      programWords <- newGrowableWord32 256
      asConstraintStep (placeConstraintEndpoint mutable operation Nothing fromPoint fromVertex)
        `bindMutable` \from ->
          asConstraintStep (placeConstraintEndpoint mutable operation Nothing toPoint toVertex)
            `bindMutable` \to ->
              applyAndPublishConstraint programWords mutable operation from to
-- | The common singleton case already owns both sites. Resolve them before
-- opening topology, then retain the original payload and counter semantics in
-- the transaction. The corridor worker is unchanged; only two redundant point
-- locations and two unused vertex-capacity reservations disappear.
applyConstraintToExistingEndpoints
  :: Triangulation 'Constrained vertex directed undirected face
  -> VertexId
  -> vertex
  -> VertexId
  -> vertex
  -> Either (CdtError) (ConstraintResult vertex directed undirected face)
applyConstraintToExistingEndpoints triangulation from@(VertexId rawFrom) fromPayload to@(VertexId rawTo) toPayload =
  runST $ do
    mutable <- thawTriangulation (Dcel.numVertices triangulation) triangulation
    operation <- newOperationState (halfEdgeCapacity mutable)
    programWords <- newGrowableWord32 256
    addCounter operation CounterInputPoints 2
    addCounter operation CounterExistingPoints 2
    addCounter operation CounterDuplicatePoints 2
    writeVertexData mutable (fromIntegral rawFrom) fromPayload
    writeVertexData mutable (fromIntegral rawTo) toPayload
    applyAndPublishConstraint programWords mutable operation from to

applyAndPublishConstraint
  :: GrowableWord32 s
  -> MutableDcel s vertex directed undirected face
  -> OperationState s
  -> VertexId
  -> VertexId
  -> ST s (Either (CdtError) (ConstraintResult vertex directed undirected face))
applyAndPublishConstraint programWords mutable operation from to =
  applyMutableConstraint programWords mutable operation from to
    `bindMutable` \applied ->
      case applied of
        MutableConstraintRejected blocking ->
          pure (Left (ConstraintIntersection blocking))
        MutableConstraintAccepted request ->
          publishConstraintResult
            mutable
            (accumulatedRequestPath request)
            (accumulatedRequestAddedEdges request)
{-# INLINE applyAndPublishConstraint #-}

-- | Close the transaction on an accepted request. The accumulated path runs
-- newest-first, so it is reversed exactly once, here.
publishConstraintResult
  :: MutableDcel s vertex directed undirected face
  -> [DirectedEdgeId]
  -> Int
  -> ST s (Either (CdtError) (ConstraintResult vertex directed undirected face))
publishConstraintResult mutable reversedPath added = do
  frozenOutcome <- freezeTriangulation mutable
  pure $ case frozenOutcome of
    Left obstruction -> Left (CdtBuildError obstruction)
    Right frozen ->
      Right
        ConstraintResult
          { constraintTriangulation = frozen
          , constraintPath = V.fromList (reverse reversedPath)
          , constraintAddedEdges = added
          }

-- | Insert a polyline's vertices and recover each adjacent segment as a
-- constraint, optionally closing the final segment back to the first.
addConstraintEdges
  :: HasPosition vertex
  => Triangulation 'Constrained vertex directed undirected face
  -> V.Vector vertex
  -> Bool
  -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face)
addConstraintEdges triangulation polylineVertices closed
  | V.null polylineVertices = Right triangulation
  | otherwise = do
      (withVertices, handles) <- insertPolylineVertices triangulation polylineVertices
      let adjacent = V.zip handles (V.drop 1 handles)
          closing =
            if closed && V.length handles > 1
              then
                case (handles V.!? (V.length handles - 1), handles V.!? 0) of
                  (Just finalVertex, Just firstVertex) ->
                    V.singleton (finalVertex, firstVertex)
                  _ -> V.empty
              else V.empty
      batch <- recoverConstraints withVertices (adjacent V.++ closing)
      case V.foldl' firstBlocking Nothing (constraintBatchOutcomes batch) of
        Nothing -> Right (constraintBatchTriangulation batch)
        Just blocking -> Left (ConstraintIntersection blocking)
 where
  firstBlocking found@(Just _) _ = found
  firstBlocking Nothing outcome =
    case outcome of
      ConstraintAccepted _ _ -> Nothing
      ConstraintRejected blocking -> Just blocking

insertPolylineVertices
  :: HasPosition vertex
  => Triangulation 'Constrained vertex directed undirected face
  -> V.Vector vertex
  -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face, V.Vector VertexId)
insertPolylineVertices triangulation points = do
  result <- mapLeft CdtBuildError (insertMany triangulation points)
  let !mapping = buildInputVertices result
  pure (buildTriangulation result, V.generate (sizeofPrimArray mapping) (VertexId . indexPrimArray mapping))

-- | Retire one constraint edge and restore local Delaunay legality.
removeConstraintEdge
  :: Triangulation 'Constrained vertex directed undirected face
  -> UndirectedEdgeId
  -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face)
removeConstraintEdge triangulation edge@(UndirectedEdgeId raw)
  | fromIntegral raw >= edgeCount =
      Left (ConstraintEdgeIndexOutOfRange edge edgeCount)
  -- An edge carrying no constraint has nothing to retire, and answering that
  -- without thawing is the difference between O(1) and a republished mesh.
  | not (Dcel.isConstraintEdge triangulation edge) = Right triangulation
  | otherwise = runST $ do
      mutable <- thawTriangulation (Dcel.numVertices triangulation) triangulation
      operation <- newOperationState (halfEdgeCapacity mutable)
      retireConstraintEdge mutable operation edge `bindMutable` \() ->
        fmap (mapLeft CdtBuildError) (freezeTriangulation mutable)
 where
  edgeCount = Dcel.numUndirectedEdges triangulation

-- | Retire one constraint inside the open transaction and restore the Delaunay
-- property across the edge it protected.
retireConstraintEdge
  :: MutableDcel s vertex directed undirected face
  -> OperationState s
  -> UndirectedEdgeId
  -> ST s (Either (CdtError) ())
retireConstraintEdge mutable operation edge@(UndirectedEdgeId raw) = do
  halfEdges <- directedEdgeCount mutable
  let !directed = fromIntegral raw * 2
  if directed >= halfEdges
    then pure (Left (ConstraintEdgeIndexOutOfRange edge (halfEdges `quot` 2)))
    else do
      constrained <- readConstraint mutable directed
      if not constrained
        then pure (Right ())
        else do
          _ <- clearConstraint mutable directed
          legalizeEdges mutable operation [directed]
          pure (Right ())