ABI.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

module Moonlight.Triangulation.Foreign.ABI
  ( CObstruction (..)
  , delaunayF64
  , meshInsertManyF64
  , meshUnion
  , meshIntersection
  , meshDifference
  , meshSymmetricDifference
  , meshVertexCount
  , meshTriangleCount
  , meshCopyVerticesF64
  , meshCopyTrianglesU32
  , meshFree
  ) where

import Control.Exception (SomeException, displayException, try)
import Control.Monad (void)
import Data.Foldable (traverse_)
import Data.Word (Word32, Word64)
import Foreign.C.String (peekCString, withCStringLen)
import Foreign.C.Types (CDouble (..), CSize (..), CUInt (..))
import Foreign.Marshal.Utils (copyBytes, fillBytes)
import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr)
import Foreign.StablePtr
  ( StablePtr
  , castPtrToStablePtr
  , castStablePtrToPtr
  , deRefStablePtr
  , freeStablePtr
  , newStablePtr
  )
import Foreign.Storable (Storable (..))
import qualified Data.Vector as V
import qualified Moonlight.Triangulation as T
import Moonlight.Triangulation.Math (validatePoint)
import qualified Moonlight.Triangulation.Session as Session

type GeometryMesh = T.DelaunayTriangulation ()

data CObstruction = CObstruction
  { obstructionCode :: !Word32
  , obstructionCoordinateError :: !Word32
  , obstructionInputIndex :: !Word64
  , obstructionFirstIndex :: !Word64
  , obstructionSecondIndex :: !Word64
  , obstructionFirstValue :: !Double
  , obstructionSecondValue :: !Double
  , obstructionPointX :: !Double
  , obstructionPointY :: !Double
  , obstructionMessage :: !String
  }
  deriving stock (Eq, Show)

instance Storable CObstruction where
  sizeOf _ = 320
  alignment _ = alignment (undefined :: Word64)
  peek pointer = do
    obstructionCode <- peekByteOff pointer 0
    obstructionCoordinateError <- peekByteOff pointer 4
    obstructionInputIndex <- peekByteOff pointer 8
    obstructionFirstIndex <- peekByteOff pointer 16
    obstructionSecondIndex <- peekByteOff pointer 24
    obstructionFirstValue <- peekByteOff pointer 32
    obstructionSecondValue <- peekByteOff pointer 40
    obstructionPointX <- peekByteOff pointer 48
    obstructionPointY <- peekByteOff pointer 56
    obstructionMessage <- peekCString (castPtr pointer `plusPtr` 64)
    pure CObstruction {..}
  poke pointer CObstruction {..} = do
    pokeByteOff pointer 0 obstructionCode
    pokeByteOff pointer 4 obstructionCoordinateError
    pokeByteOff pointer 8 obstructionInputIndex
    pokeByteOff pointer 16 obstructionFirstIndex
    pokeByteOff pointer 24 obstructionSecondIndex
    pokeByteOff pointer 32 obstructionFirstValue
    pokeByteOff pointer 40 obstructionSecondValue
    pokeByteOff pointer 48 obstructionPointX
    pokeByteOff pointer 56 obstructionPointY
    let messagePointer = castPtr pointer `plusPtr` 64
    fillBytes messagePointer 0 256
    withCStringLen obstructionMessage $ \(source, lengthInBytes) ->
      copyBytes messagePointer source (min 255 lengthInBytes)

data AbiFailure = AbiFailure !CUInt !CObstruction

statusOk, statusNullPointer, statusCountOverflow, statusBufferTooSmall, statusBuildObstruction, statusRuntimeFailure :: CUInt
statusOk = 0
statusNullPointer = 1
statusCountOverflow = 2
statusBufferTooSmall = 3
statusBuildObstruction = 4
statusRuntimeFailure = 5

emptyObstruction :: CObstruction
emptyObstruction =
  CObstruction
    { obstructionCode = 0
    , obstructionCoordinateError = 0
    , obstructionInputIndex = maxBound
    , obstructionFirstIndex = 0
    , obstructionSecondIndex = 0
    , obstructionFirstValue = 0
    , obstructionSecondValue = 0
    , obstructionPointX = 0
    , obstructionPointY = 0
    , obstructionMessage = ""
    }

apiFailure :: CUInt -> Word32 -> String -> AbiFailure
apiFailure status code message =
  AbiFailure status emptyObstruction {obstructionCode = code, obstructionMessage = message}

nullPointerFailure :: String -> AbiFailure
nullPointerFailure label = apiFailure statusNullPointer 100 (label <> " must not be null")

countOverflowFailure :: Word64 -> AbiFailure
countOverflowFailure count =
  AbiFailure statusCountOverflow emptyObstruction
    { obstructionCode = 101
    , obstructionFirstIndex = count
    , obstructionMessage = "count exceeds the host Int range"
    }

bufferTooSmallFailure :: Int -> Int -> AbiFailure
bufferTooSmallFailure required capacity =
  AbiFailure statusBufferTooSmall emptyObstruction
    { obstructionCode = 102
    , obstructionFirstIndex = fromIntegral required
    , obstructionSecondIndex = fromIntegral capacity
    , obstructionMessage = "output buffer is smaller than the required element count"
    }

runtimeFailure :: SomeException -> AbiFailure
runtimeFailure = apiFailure statusRuntimeFailure 103 . displayException

runBoundary :: Ptr CObstruction -> IO (Either AbiFailure ()) -> IO CUInt
runBoundary obstructionPointer action = do
  writeObstruction obstructionPointer emptyObstruction
  outcome <- try action :: IO (Either SomeException (Either AbiFailure ()))
  case outcome of
    Left exception -> finishFailure obstructionPointer (runtimeFailure exception)
    Right (Left failure) -> finishFailure obstructionPointer failure
    Right (Right ()) -> pure statusOk

finishFailure :: Ptr CObstruction -> AbiFailure -> IO CUInt
finishFailure obstructionPointer (AbiFailure status obstruction) = do
  writeObstruction obstructionPointer obstruction
  pure status

writeObstruction :: Ptr CObstruction -> CObstruction -> IO ()
writeObstruction pointer obstruction
  | pointer == nullPtr = pure ()
  | otherwise = poke pointer obstruction

requirePointer :: String -> Ptr value -> Either AbiFailure ()
requirePointer label pointer
  | pointer == nullPtr = Left (nullPointerFailure label)
  | otherwise = Right ()

checkedCount :: Int -> CSize -> Either AbiFailure Int
checkedCount elementsPerItem rawCount
  | toInteger rawCount * toInteger elementsPerItem > toInteger (maxBound :: Int) =
      Left (countOverflowFailure (fromIntegral rawCount))
  | otherwise = Right (fromIntegral rawCount)

readPoints :: Ptr CDouble -> Int -> IO (Either AbiFailure (V.Vector T.Point))
readPoints pointer count
  | count == 0 = pure (Right V.empty)
  | pointer == nullPtr = pure (Left (nullPointerFailure "coordinates"))
  | otherwise =
      Right
        <$> V.generateM
              count
              ( \index -> do
                  CDouble x <- peekElemOff pointer (index * 2)
                  CDouble y <- peekElemOff pointer (index * 2 + 1)
                  pure (T.Point x y)
              )

prepareMeshOutput :: Ptr (Ptr ()) -> IO (Either AbiFailure ())
prepareMeshOutput pointer =
  case requirePointer "result" pointer of
    Left failure -> pure (Left failure)
    Right () -> poke pointer nullPtr >> pure (Right ())

publishMesh :: Ptr (Ptr ()) -> GeometryMesh -> IO ()
publishMesh output mesh = do
  stable <- newStablePtr mesh
  poke output (castStablePtrToPtr stable)

produceMesh :: Ptr (Ptr ()) -> IO (Either AbiFailure (Either T.BuildError GeometryMesh)) -> IO (Either AbiFailure ())
produceMesh output obtain = do
  prepared <- prepareMeshOutput output
  case prepared of
    Left failure -> pure (Left failure)
    Right () -> do
      outcome <- obtain
      case outcome of
        Left failure -> pure (Left failure)
        Right (Left obstruction) ->
          pure (Left (AbiFailure statusBuildObstruction (buildErrorObstruction obstruction)))
        Right (Right mesh) -> publishMesh output mesh >> pure (Right ())

delaunayF64 :: Ptr CDouble -> CSize -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt
delaunayF64 coordinates rawCount output obstructionPointer =
  runBoundary obstructionPointer $ produceMesh output $ do
    case checkedCount 2 rawCount of
      Left failure -> pure (Left failure)
      Right count -> fmap (fmap T.delaunayGeometry) (readPoints coordinates count)

meshInsertManyF64 :: Ptr () -> Ptr CDouble -> CSize -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt
meshInsertManyF64 meshPointer coordinates rawCount output obstructionPointer =
  runBoundary obstructionPointer $ produceMesh output $ do
    case (requirePointer "mesh" meshPointer, checkedCount 2 rawCount) of
      (Left failure, _) -> pure (Left failure)
      (_, Left failure) -> pure (Left failure)
      (Right (), Right count) -> do
        pointsOutcome <- readPoints coordinates count
        case pointsOutcome of
          Left failure -> pure (Left failure)
          Right points -> do
            mesh <- dereferenceMesh meshPointer
            pure (Right (insertGeometryBatch mesh points))

insertGeometryBatch :: GeometryMesh -> V.Vector T.Point -> Either T.BuildError GeometryMesh
insertGeometryBatch mesh points = do
  normalized <-
    V.imapM
      (\index point -> T.queryPointValue <$> validatePoint (Just index) point)
      points
  (_, revised, _) <-
    Session.withSession
      mesh
      (V.length normalized)
      (traverse_ (\point -> void (Session.insertVertexAt point ())) normalized)
  pure revised

meshUnion, meshIntersection, meshDifference, meshSymmetricDifference :: Ptr () -> Ptr () -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt
meshUnion = binaryMeshOperation T.union
meshIntersection = binaryMeshOperation T.intersection
meshDifference = binaryMeshOperation T.difference
meshSymmetricDifference = binaryMeshOperation T.symmetricDifference

binaryMeshOperation :: (GeometryMesh -> GeometryMesh -> Either T.BuildError GeometryMesh) -> Ptr () -> Ptr () -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt
binaryMeshOperation operation leftPointer rightPointer output obstructionPointer =
  runBoundary obstructionPointer $ produceMesh output $ do
    case (requirePointer "left mesh" leftPointer, requirePointer "right mesh" rightPointer) of
      (Left failure, _) -> pure (Left failure)
      (_, Left failure) -> pure (Left failure)
      (Right (), Right ()) -> do
        left <- dereferenceMesh leftPointer
        right <- dereferenceMesh rightPointer
        pure (Right (operation left right))

meshVertexCount, meshTriangleCount :: Ptr () -> Ptr CSize -> Ptr CObstruction -> IO CUInt
meshVertexCount = meshCount T.numVertices
meshTriangleCount = meshCount (V.length . T.innerFaceVertexTriples)

meshCount :: (GeometryMesh -> Int) -> Ptr () -> Ptr CSize -> Ptr CObstruction -> IO CUInt
meshCount observe meshPointer output obstructionPointer =
  runBoundary obstructionPointer $
    case (requirePointer "mesh" meshPointer, requirePointer "count" output) of
      (Left failure, _) -> pure (Left failure)
      (_, Left failure) -> pure (Left failure)
      (Right (), Right ()) -> do
        mesh <- dereferenceMesh meshPointer
        poke output (fromIntegral (observe mesh))
        pure (Right ())

meshCopyVerticesF64 :: Ptr () -> Ptr CDouble -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt
meshCopyVerticesF64 =
  copyMeshProjection
    "points_written"
    "coordinates"
    T.vertexPoints
    ( \output index (T.Point x y) -> do
        pokeElemOff output (index * 2) (CDouble x)
        pokeElemOff output (index * 2 + 1) (CDouble y)
    )

meshCopyTrianglesU32 :: Ptr () -> Ptr Word32 -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt
meshCopyTrianglesU32 =
  copyMeshProjection
    "triangles_written"
    "triangles"
    T.innerFaceVertexTriples
    ( \output index (first, second, third) -> do
        pokeElemOff output (index * 3) (T.unVertexId first)
        pokeElemOff output (index * 3 + 1) (T.unVertexId second)
        pokeElemOff output (index * 3 + 2) (T.unVertexId third)
    )

copyMeshProjection
  :: String -> String -> (GeometryMesh -> V.Vector item) -> (Ptr element -> Int -> item -> IO ())
  -> Ptr () -> Ptr element -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt
{-# INLINE copyMeshProjection #-}
copyMeshProjection writtenLabel outputLabel project writeItem meshPointer output rawCapacity written obstructionPointer =
  runBoundary obstructionPointer $
    case (requirePointer "mesh" meshPointer, requirePointer writtenLabel written, checkedCount 1 rawCapacity) of
      (Left failure, _, _) -> pure (Left failure)
      (_, Left failure, _) -> pure (Left failure)
      (_, _, Left failure) -> pure (Left failure)
      (Right (), Right (), Right capacity) -> do
        mesh <- dereferenceMesh meshPointer
        let items = project mesh
            required = V.length items
        poke written (fromIntegral required)
        case requireOutputCapacity outputLabel output required capacity of
          Left failure -> pure (Left failure)
          Right () -> V.imapM_ (writeItem output) items >> pure (Right ())

requireOutputCapacity :: String -> Ptr value -> Int -> Int -> Either AbiFailure ()
requireOutputCapacity label output required capacity
  | capacity < required = Left (bufferTooSmallFailure required capacity)
  | required > 0 = requirePointer label output
  | otherwise = Right ()

dereferenceMesh :: Ptr () -> IO GeometryMesh
dereferenceMesh = deRefStablePtr . (castPtrToStablePtr :: Ptr () -> StablePtr GeometryMesh)

meshFree :: Ptr () -> IO ()
meshFree pointer
  | pointer == nullPtr = pure ()
  | otherwise = freeStablePtr ((castPtrToStablePtr pointer) :: StablePtr GeometryMesh)

buildErrorObstruction :: T.BuildError -> CObstruction
buildErrorObstruction failure =
  (case failure of
    T.InvalidCoordinate inputIndex value reason ->
      emptyObstruction
        { obstructionCode = 1
        , obstructionCoordinateError = coordinateErrorCode reason
        , obstructionInputIndex = maybe maxBound fromIntegral inputIndex
        , obstructionFirstValue = value
        }
    T.PointLocationFailed (T.Point x y) -> pointObstruction 2 x y
    T.LocationWalkExhausted (T.Point x y) steps ->
      (pointObstruction 3 x y) {obstructionFirstIndex = fromIntegral steps}
    T.RefinementInputTopologyInvalid _ -> codeOnly 4
    T.FreshInsertionMatchedExistingVertex first second -> indices 5 (T.unVertexId first) (T.unVertexId second)
    T.DegenerateLineEndpointMissingOutgoing vertex -> firstIndex 6 (T.unVertexId vertex)
    T.DegenerateLineEndpointTurnMissing index -> firstIndex 7 index
    T.DegenerateLineConnectedVertexMissing index -> firstIndex 8 index
    T.HullStartNotVisible edge -> firstIndex 9 (T.unDirectedEdgeId edge)
    T.OuterRangeDidNotTerminate first second steps ->
      (indices 10 (T.unDirectedEdgeId first) (T.unDirectedEdgeId second))
        {obstructionFirstValue = fromIntegral steps}
    T.OuterRangeContainsInnerEdge edge face -> indices 11 (T.unDirectedEdgeId edge) (T.unFaceId face)
    T.ConstrainedEdgeFlipRefused edge -> firstIndex 12 (T.unUndirectedEdgeId edge)
    T.RemovalVertexOutOfRange vertex count -> indices 13 (T.unVertexId vertex) count
    T.RemovalEdgeOutOfRange edge count -> indices 14 (T.unUndirectedEdgeId edge) count
    T.RemovalFaceOutOfRange face count -> indices 15 (T.unFaceId face) count
    T.RemovalFaceCycleDidNotTerminate face edge steps ->
      (indices 16 (T.unFaceId face) (T.unDirectedEdgeId edge))
        {obstructionFirstValue = fromIntegral steps}
    T.RemovalEmptyTriangulation vertex -> firstIndex 17 (T.unVertexId vertex)
    T.RemovalTwoPointDegreeMismatch vertex degree -> indices 18 (T.unVertexId vertex) degree
    T.RemovalCollinearDegreeMismatch vertex degree -> indices 19 (T.unVertexId vertex) degree
    T.RemovalBorderTooShort count -> firstIndex 20 count
    T.RemovalBorderArityMismatch count -> firstIndex 21 count
    T.RemovalOutgoingCycleDidNotTerminate vertex edge steps ->
      (indices 22 (T.unVertexId vertex) (T.unDirectedEdgeId edge))
        {obstructionFirstValue = fromIntegral steps}
    T.CircleSweepHullEmpty -> codeOnly 23
    T.OuterCycleDidNotTerminate first second steps ->
      (indices 24 (T.unDirectedEdgeId first) (T.unDirectedEdgeId second))
        {obstructionFirstValue = fromIntegral steps}
    T.HierarchyLevelPopulationMismatch level expected observed ->
      (indices 25 expected observed) {obstructionFirstValue = fromIntegral level}
    T.HierarchyInsertionHandleMismatch expected observed -> indices 26 (T.unVertexId expected) (T.unVertexId observed)
    T.PointIndexCapacityExhausted count -> firstIndex 27 count
    T.RefinementMinimumAngleNotFinite value -> nonFinite 28 value
    T.RefinementMinimumAngleOutOfRange value -> firstValue 29 value
    T.RefinementMinimumAngleDerivedRatioNotFinite value -> nonFinite 30 value
    T.RefinementMaximumAdditionalVerticesNegative value -> firstValue 31 (fromIntegral value)
    T.RefinementMinimumAreaNotFinite value -> nonFinite 32 value
    T.RefinementMinimumAreaNegative value -> firstValue 33 value
    T.RefinementMaximumAreaNotFinite value -> nonFinite 34 value
    T.RefinementMaximumAreaNotPositive value -> firstValue 35 value
    T.RefinementMaximumRadiusEdgeRatioNotFinite value -> nonFinite 36 value
    T.RefinementMaximumRadiusEdgeRatioNotPositive value -> firstValue 37 value
    T.RefinementMinimumAreaExceedsMaximum minimumArea maximumArea -> values 38 minimumArea maximumArea
    T.RefinementSeedFaceNotActive face count -> indices 39 (T.unFaceId face) count
    T.RefinementDomainInterfaceEdgeNotActive edge count -> indices 40 (T.unUndirectedEdgeId edge) count
    T.RefinementDomainInterfaceMissing edge -> firstIndex 41 (T.unUndirectedEdgeId edge)
    T.RefinementDomainInterfaceExtraneous edge -> firstIndex 42 (T.unUndirectedEdgeId edge)
    T.RefinementDomainTopologyChanged -> codeOnly 43
    T.RefinementDomainRequiresConvexHullPreservation -> codeOnly 44
    T.RefinementDomainRequiresConstraintPreservation -> codeOnly 45
    T.RefinementDomainForbidsOuterFaceExclusion -> codeOnly 46
    T.RefinementDomainWouldCrossInterface edge face -> indices 47 (T.unUndirectedEdgeId edge) (T.unFaceId face)
    T.RefinementDomainWouldRewriteProtectedFace face -> firstIndex 48 (T.unFaceId face)
    T.RefinementDomainProtectedFaceChanged face -> firstIndex 49 (T.unFaceId face)
    T.CapacityExceeded count -> firstIndex 50 count
    T.HalfEdgeCapacityExceeded requested capacity -> indices 51 requested capacity
    T.FaceCapacityExceeded requested capacity -> indices 52 requested capacity
    T.PayloadStorageFailure _ -> codeOnly 53
    T.CoordinatePayloadCountMismatch coordinates payloads -> indices 54 coordinates payloads
  )
    {obstructionMessage = show failure}
 where
  codeOnly :: Word32 -> CObstruction
  codeOnly code = emptyObstruction {obstructionCode = code}
  firstIndex :: Integral index => Word32 -> index -> CObstruction
  firstIndex code index = (codeOnly code) {obstructionFirstIndex = fromIntegral index}
  indices :: (Integral first, Integral second) => Word32 -> first -> second -> CObstruction
  indices code first second =
    (codeOnly code)
      { obstructionFirstIndex = fromIntegral first
      , obstructionSecondIndex = fromIntegral second
      }
  firstValue :: Word32 -> Double -> CObstruction
  firstValue code value = (codeOnly code) {obstructionFirstValue = value}
  values :: Word32 -> Double -> Double -> CObstruction
  values code first second =
    (codeOnly code)
      { obstructionFirstValue = first
      , obstructionSecondValue = second
      }
  pointObstruction :: Word32 -> Double -> Double -> CObstruction
  pointObstruction code x y =
    (codeOnly code)
      { obstructionPointX = x
      , obstructionPointY = y
      }
  nonFinite :: Word32 -> T.NonFiniteValue -> CObstruction
  nonFinite code value = firstIndex code (nonFiniteCode value)

coordinateErrorCode :: T.CoordinateError -> Word32
coordinateErrorCode reason =
  case reason of
    T.CoordinateNaN -> 1
    T.CoordinateInfinite -> 2
    T.CoordinateTooSmall -> 3
    T.CoordinateTooLarge -> 4

nonFiniteCode :: T.NonFiniteValue -> Word32
nonFiniteCode value =
  case value of
    T.ValueNaN -> 1
    T.ValuePositiveInfinity -> 2
    T.ValueNegativeInfinity -> 3