module Main (main) where
import Control.Exception (bracket)
import Control.Monad (unless)
import Data.Word (Word32)
import Foreign.C.Types (CDouble (..), CSize (..), CUInt)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (allocaArray, peekArray, withArray)
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Storable (Storable (sizeOf), peek)
import Moonlight.Triangulation.Foreign.ABI
type MeshPointer = Ptr ()
main :: IO ()
main = do
unless (sizeOf (undefined :: CObstruction) == 320) $
fail "C obstruction layout changed"
bracket (buildMesh [(0, 0), (2, 0), (0, 2), (2, 2)]) meshFree $ \left ->
bracket (buildMesh [(2, 0), (4, 0), (2, 2), (4, 2)]) meshFree $ \right -> do
requireMeshCount "left vertex count" meshVertexCount left 4
requireMeshCount "left triangle count" meshTriangleCount left 2
testDenseCopies left
testImmutableBatch left
testBinaryAlgebra left right
testTypedCoordinateRefusal
testCoordinateCountOverflow
testNullPointerRefusal
putStrLn "ffi: ok"
buildMesh :: [(Double, Double)] -> IO MeshPointer
buildMesh points =
withPointArray points $ \coordinates ->
alloca $ \output ->
alloca $ \obstruction -> do
status <- delaunayF64 coordinates (fromIntegral (length points)) output obstruction
requireStatus "delaunay" 0 status obstruction
handle <- peek output
unless (handle /= nullPtr) (fail "delaunay returned a null handle")
pure handle
testDenseCopies :: MeshPointer -> IO ()
testDenseCopies mesh = do
alloca $ \written ->
alloca $ \obstruction -> do
status <- meshCopyVerticesF64 mesh nullPtr 0 written obstruction
requireStatus "undersized vertex copy" 3 status obstruction
required <- peek written
refusal <- peek obstruction
unless (required == 4 && obstructionCode refusal == 102) $
fail "undersized vertex copy lost its required-capacity witness"
allocaArray 8 $ \coordinates ->
alloca $ \written ->
alloca $ \obstruction -> do
status <- meshCopyVerticesF64 mesh coordinates 4 written obstruction
requireStatus "vertex copy" 0 status obstruction
values <- peekArray 8 coordinates
unless (length values == 8) (fail "vertex copy wrote the wrong coordinate extent")
allocaArray 6 $ \triangles ->
alloca $ \written ->
alloca $ \obstruction -> do
status <- meshCopyTrianglesU32 mesh triangles 2 written obstruction
requireStatus "triangle copy" 0 status obstruction
indices <- peekArray 6 triangles :: IO [Word32]
unless (all (< 4) indices) (fail "triangle copy produced an out-of-range vertex")
testImmutableBatch :: MeshPointer -> IO ()
testImmutableBatch original =
withPointArray [(1, 1), (3, 1)] $ \coordinates ->
bracket
(produceMesh "batch insert" (meshInsertManyF64 original coordinates 2))
meshFree
(\revised -> do
requireMeshCount "original after batch" meshVertexCount original 4
requireMeshCount "revised after batch" meshVertexCount revised 6
)
testBinaryAlgebra :: MeshPointer -> MeshPointer -> IO ()
testBinaryAlgebra left right = do
test "union" meshUnion 6
test "intersection" meshIntersection 2
test "difference" meshDifference 2
test "symmetric difference" meshSymmetricDifference 4
where
test label operation expected =
bracket (produceMesh label (operation left right)) meshFree $ \result ->
requireMeshCount label meshVertexCount result expected
testTypedCoordinateRefusal :: IO ()
testTypedCoordinateRefusal =
withPointArray [(0, 0), (0 / 0, 1), (1, 0)] $ \coordinates ->
alloca $ \output ->
alloca $ \obstruction -> do
status <- delaunayF64 coordinates 3 output obstruction
requireStatus "invalid coordinate" 4 status obstruction
refusal <- peek obstruction
unless (obstructionCode refusal == 1 && obstructionCoordinateError refusal == 1 && obstructionInputIndex refusal == 1) $
fail "invalid coordinate lost its typed witness"
testNullPointerRefusal :: IO ()
testNullPointerRefusal =
alloca $ \count ->
alloca $ \obstruction -> do
status <- meshVertexCount nullPtr count obstruction
requireStatus "null mesh" 1 status obstruction
refusal <- peek obstruction
unless (obstructionCode refusal == 100) $
fail "null pointer refusal lost its typed witness"
testCoordinateCountOverflow :: IO ()
testCoordinateCountOverflow =
alloca $ \output ->
alloca $ \obstruction -> do
let overflowingCount = fromIntegral (maxBound `div` 2 + 1 :: Int)
status <- delaunayF64 nullPtr overflowingCount output obstruction
requireStatus "coordinate count overflow" 2 status obstruction
refusal <- peek obstruction
unless (obstructionCode refusal == 101) $
fail "coordinate count overflow lost its typed witness"
requireMeshCount :: String -> (MeshPointer -> Ptr CSize -> Ptr CObstruction -> IO CUInt) -> MeshPointer -> Int -> IO ()
requireMeshCount label operation mesh expected =
alloca $ \count ->
alloca $ \obstruction -> do
status <- operation mesh count obstruction
requireStatus label 0 status obstruction
observed <- peek count
unless (observed == fromIntegral expected) $
fail (label <> " produced " <> show observed <> ", expected " <> show expected)
produceMesh :: String -> (Ptr MeshPointer -> Ptr CObstruction -> IO CUInt) -> IO MeshPointer
produceMesh label operation =
alloca $ \output ->
alloca $ \obstruction -> do
status <- operation output obstruction
requireStatus label 0 status obstruction
handle <- peek output
unless (handle /= nullPtr) (fail (label <> " returned a null handle"))
pure handle
requireStatus :: String -> CUInt -> CUInt -> Ptr CObstruction -> IO ()
requireStatus label expected observed obstruction
| observed == expected = pure ()
| otherwise = do
refusal <- peek obstruction
fail (label <> " returned status " <> show observed <> ": " <> obstructionMessage refusal)
withPointArray :: [(Double, Double)] -> (Ptr CDouble -> IO result) -> IO result
withPointArray points = withArray (concatMap (\(x, y) -> [CDouble x, CDouble y]) points)