Serialization.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | The versioned binary surface: encode a triangulation to bytes and read it
-- back. Decoding refuses a payload whose format version or coordinate encoding this
-- build does not own, rather than reinterpreting it.
module Moonlight.Triangulation.Serialization
  ( DecodingBudget (..)
  , TrustedPayloadDecoders
  , trustedBinaryPayloadDecoders
  , SerializedCountKind (..)
  , SerializationError (..)
  , serializationVersion
  , encodeTriangulation
  , decodeTriangulation
  ) where

import Control.Monad (unless, when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Data.Binary (Binary (..))
import Data.Binary.Get
  ( Get
  , bytesRead
  , getDoublebe
  , getWord16be
  , getWord32be
  , getWord64be
  , getWord8
  , runGetOrFail
  )
import Data.Binary.Put
  ( putDoublebe
  , putWord16be
  , putWord32be
  , putWord64be
  , putWord8
  , runPut
  )
import qualified Data.ByteString.Lazy as BL
import Data.Foldable (traverse_)
import qualified Data.IntSet as IntSet
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Proxy (Proxy (..))
import qualified Data.Set as Set
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import Data.Word (Word16, Word64, Word8)
import Moonlight.Triangulation.Internal.BoxedPaged
  ( boxedFill
  , boxedFromVector
  , boxedToVector
  )
import Moonlight.Triangulation.Internal.Paged (fromLocalVector, fromVector, toVector)
import Moonlight.Triangulation.Internal.PackedIndex (indexLimit)
import Moonlight.Triangulation.Internal.PointIndex (buildPointIndex)
import Moonlight.Triangulation.Handles.HandleDefs
import Moonlight.Triangulation.Internal.Representation
import Moonlight.Triangulation.Internal.Types
import Moonlight.Triangulation.Math (mkQueryPoint)
import Moonlight.Triangulation.Validation (validateTriangulation)

instance Binary (Point) where
  put (Point x y) = putDoublebe x >> putDoublebe y
  get = Point <$> getDoublebe <*> getDoublebe

instance Binary VertexId where
  put (VertexId value) = putWord32be value
  get = VertexId <$> getWord32be

instance Binary FaceId where
  put (FaceId value) = putWord32be value
  get = FaceId <$> getWord32be

instance Binary DirectedEdgeId where
  put (DirectedEdgeId value) = putWord32be value
  get = DirectedEdgeId <$> getWord32be

instance Binary UndirectedEdgeId where
  put (UndirectedEdgeId value) = putWord32be value
  get = UndirectedEdgeId <$> getWord32be

-- | The finite resource envelope admitted by the canonical decoder. The byte
-- budget bounds the complete input before parsing; the element budget bounds
-- the total number of library-owned serialized section elements before any
-- section is allocated.
data DecodingBudget = DecodingBudget
  { decodingMaximumInputBytes :: !Word64
  , decodingMaximumSectionElements :: !Word64
  }
  deriving stock (Eq, Show)

-- | Evidence that the caller accepts the internal resource behavior of all
-- four payload decoders. The structural budget governs only containers owned
-- by this module; executable payload decoders require this separate trust law.
data TrustedPayloadDecoders vertex directed undirected face where
  TrustedBinaryPayloadDecoders
    :: ( Binary vertex
       , Binary directed
       , Binary undirected
       , Binary face
       )
    => TrustedPayloadDecoders vertex directed undirected face

-- | Explicitly trust the selected 'Binary' payload instances. This witness is
-- required because arbitrary instances may allocate independently of input
-- bytes; constructing it declares that the caller has audited that behavior.
trustedBinaryPayloadDecoders
  :: ( Binary vertex
     , Binary directed
     , Binary undirected
     , Binary face
     )
  => TrustedPayloadDecoders vertex directed undirected face
trustedBinaryPayloadDecoders = TrustedBinaryPayloadDecoders

-- | The structural count whose encoded value was outside the resident index
-- or allocation domain.
data SerializedCountKind
  = SerializedVertexCount
  | SerializedDirectedEdgeCount
  | SerializedFaceCount
  | SerializedConstraintCount
  deriving stock (Eq, Ord, Show)

-- | Every way serialization refuses, each naming its witness.
data SerializationError
  = BinaryDecodeFailure !Int64 !String
  | TrailingBytes !Int64
  | InvalidFormatMagic !Word64
  | UnsupportedFormatVersion !Word16
  | ConstraintModeTagMismatch !Word8 !Word8
  | CoordinateEncodingTagMismatch !Word8 !Word8
  | InputByteBudgetExceeded !Word64 !Word64
  | DecodedSectionBudgetExceeded !Word64 !Word64
  | EncodedCountExceedsInt !SerializedCountKind !Word64
  | EncodedCountExceedsPackedIndex !SerializedCountKind !Word64 !Word64
  | SerializedDirectedEdgeCountOdd !Word64
  | SerializedConstraintCountExceedsEdges !Word64 !Word64
  | SerializedPlanarCardinalityMismatch !Word64 !Word64 !Word64
  | SerializedFixedBodyTooShort !Word64 !Word64
  | SerializedMissingOuterFace
  | InvalidSerializedPoint {-# UNPACK #-} !Int !PointValidationError
  | NonCanonicalSerializedConstraintFlag !UndirectedEdgeId !Word8
  | SerializedConstraintCountMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int
  | UnconstrainedSerializedConstraints {-# UNPACK #-} !Int
  | DuplicateSerializedCoordinates {-# UNPACK #-} !Int {-# UNPACK #-} !Int
  | DecodedInvariantViolations !(NonEmpty InvariantViolation)
  deriving stock (Eq, Show)

type Decoder = ExceptT SerializationError Get

-- | The envelope version this module writes.
serializationVersion :: Word16
serializationVersion = 6

formatMagic :: Word64
formatMagic = 0x5350414445485307 -- "SPADEHS" + canonical geometry-owned format family

binary64EncodingTag :: Word8
binary64EncodingTag = 2

-- | Write the versioned binary envelope.
encodeTriangulation
  :: forall mode vertex directed undirected face. (KnownConstraintMode mode, Binary vertex, Binary directed, Binary undirected, Binary face)
  => Triangulation mode vertex directed undirected face
  -> BL.ByteString
encodeTriangulation triangulation = runPut $ do
  putWord64be formatMagic
  putWord16be serializationVersion
  putWord8 (modeTag (constraintModeValue (modeProxy triangulation)))
  putWord8 binary64EncodingTag
  let ElementDefaults directedDefault undirectedDefault faceDefault = triElementDefaults triangulation
      pointXs = toVector (triPointX triangulation)
      pointYs = toVector (triPointY triangulation)
      vertexDefault = boxedFill (triVertexData triangulation)
      vertexDataVector = boxedToVector (triVertexData triangulation)
      vertexOut = toVector (triVertexOut triangulation)
      topology = toVector (triHalfTopology triangulation)
      directedDataVector = boxedToVector (triDirectedData triangulation)
      undirectedDataVector = boxedToVector (triUndirectedData triangulation)
      faceEdge = toVector (triFaceEdge triangulation)
      faceDataVector = boxedToVector (triFaceData triangulation)
      constraints = toVector (triConstraint triangulation)
      vertexCount = U.length pointXs
      directedEdgeCount = U.length topology `quot` 4
      faceCount = U.length faceEdge
  -- Version 6 commits every structural count in one prefix. The decoder can
  -- prove their relationships and resource bounds before defaults, payloads,
  -- or section bodies are evaluated.
  putWord64be (fromIntegral vertexCount)
  putWord64be (fromIntegral directedEdgeCount)
  putWord64be (fromIntegral faceCount)
  putWord64be (fromIntegral (triConstraintCount triangulation))
  put directedDefault
  put undirectedDefault
  put faceDefault
  -- Geometry and payloads are independent components. Persist the authoritative
  -- coordinate pages rather than attempting to recover them from annotations.
  U.mapM_ putDoublebe pointXs
  U.mapM_ putDoublebe pointYs
  put vertexDefault
  V.mapM_ put vertexDataVector
  U.mapM_ putWord32be vertexOut
  -- The wire format stores the four topology planes separately; the interleaved
  -- arena is a resident layout, not a serialization concern.
  let plane field = U.generate directedEdgeCount (\edge -> topology U.! (4 * edge + field))
  U.mapM_ putWord32be (plane 0)
  U.mapM_ putWord32be (plane 1)
  U.mapM_ putWord32be (plane 2)
  U.mapM_ putWord32be (plane 3)
  V.mapM_ put directedDataVector
  V.mapM_ put undirectedDataVector
  U.mapM_ putWord32be faceEdge
  V.mapM_ put faceDataVector
  U.mapM_ putWord8 constraints

-- | Decode one exact, versioned finite DCEL inside an explicit resource
-- envelope. Structural counts are read and reconciled before any default,
-- payload, or section body is decoded. Coordinate uniqueness and the complete
-- topology, geometry, and Delaunay/CDT invariants are checked before the opaque
-- value is returned.
--
-- The budget bounds the input and the containers owned by this module. The
-- required 'TrustedPayloadDecoders' witness separately records the caller's
-- decision that every selected payload decoder is internally resource-safe.
decodeTriangulation
  :: forall mode vertex directed undirected face.
     KnownConstraintMode mode
  => DecodingBudget
  -> TrustedPayloadDecoders vertex directed undirected face
  -> BL.ByteString
  -> Either SerializationError (Triangulation mode vertex directed undirected face)
decodeTriangulation budget TrustedBinaryPayloadDecoders bytes
  | inputByteCount > decodingMaximumInputBytes budget =
      Left
        ( InputByteBudgetExceeded
            inputByteCount
            (decodingMaximumInputBytes budget)
        )
  | otherwise =
      case runGetOrFail (runExceptT getTriangulation) bytes of
        Left (_, offset, message) -> Left (BinaryDecodeFailure offset message)
        Right (_, _, Left failure) -> Left failure
        Right (trailing, _, Right triangulation)
          | not (BL.null trailing) -> Left (TrailingBytes (BL.length trailing))
          | otherwise ->
              case validateTriangulation triangulation of
                [] -> Right triangulation
                firstViolation : remainingViolations ->
                  Left (DecodedInvariantViolations (firstViolation :| remainingViolations))
 where
  inputByteCount = fromIntegral (BL.length bytes)

  getTriangulation :: Decoder (Triangulation mode vertex directed undirected face)
  getTriangulation = do
    magic <- lift getWord64be
    unless (magic == formatMagic) (throwE (InvalidFormatMagic magic))
    version <- lift getWord16be
    unless (version == serializationVersion) (throwE (UnsupportedFormatVersion version))
    encodedMode <- lift getWord8
    let expectedMode = modeTag (constraintModeValue (Proxy :: Proxy mode))
    unless (encodedMode == expectedMode) (throwE (ConstraintModeTagMismatch expectedMode encodedMode))
    encodedScalar <- lift getWord8
    let expectedScalar = binary64EncodingTag
    unless (encodedScalar == expectedScalar) (throwE (CoordinateEncodingTagMismatch expectedScalar encodedScalar))
    encodedVertexCount <- lift getWord64be
    encodedDirectedEdgeCount <- lift getWord64be
    encodedFaceCount <- lift getWord64be
    encodedConstraintCount <- lift getWord64be
    validateStructuralPrefix
      budget
      encodedVertexCount
      encodedDirectedEdgeCount
      encodedFaceCount
      encodedConstraintCount
    prefixByteCount <- fromIntegral <$> lift bytesRead
    let bodyByteCount = inputByteCount - prefixByteCount
        minimumBodyByteCount =
          minimumFixedBodyBytes
            encodedVertexCount
            encodedDirectedEdgeCount
            encodedFaceCount
    unless (bodyByteCount >= minimumBodyByteCount) $
      throwE (SerializedFixedBodyTooShort bodyByteCount minimumBodyByteCount)

    let vertexCount = fromIntegral encodedVertexCount
        halfCount = fromIntegral encodedDirectedEdgeCount
        edgeCount = halfCount `quot` 2
        faceCount = fromIntegral encodedFaceCount
        cachedConstraintCount = fromIntegral encodedConstraintCount
    defaults <- ElementDefaults <$> lift get <*> lift get <*> lift get
    pointXs <- U.replicateM vertexCount (lift getDoublebe)
    pointYs <- U.replicateM vertexCount (lift getDoublebe)
    vertexDefault <- lift get
    vertexDataVector <- V.replicateM vertexCount (lift get)
    vertexOut <- U.replicateM vertexCount (lift getWord32be)
    halfOrigin <- U.replicateM halfCount (lift getWord32be)
    halfNext <- U.replicateM halfCount (lift getWord32be)
    halfPrev <- U.replicateM halfCount (lift getWord32be)
    halfFace <- U.replicateM halfCount (lift getWord32be)
    directedDataVector <- V.replicateM halfCount (lift get)
    undirectedDataVector <- V.replicateM edgeCount (lift get)
    faceEdge <- U.replicateM faceCount (lift getWord32be)
    faceDataVector <- V.replicateM faceCount (lift get)
    constraints <- U.replicateM edgeCount (lift getWord8)

    let points = V.generate vertexCount (\index -> Point (pointXs U.! index) (pointYs U.! index))
    traverse_ (uncurry validateStoredPoint) (V.indexed points)

    case U.ifoldr (\index flag found -> if flag /= 0 && flag /= 1 then Just (index, flag) else found) Nothing constraints of
      Nothing -> pure ()
      Just (index, flag) ->
        throwE
          ( NonCanonicalSerializedConstraintFlag
              (UndirectedEdgeId (fromIntegral index))
              flag
          )
    let actualConstraintCount = U.foldl' (\count flag -> if flag == 1 then count + 1 else count) 0 constraints
    unless (cachedConstraintCount == actualConstraintCount) (throwE (SerializedConstraintCountMismatch cachedConstraintCount actualConstraintCount))
    when (expectedMode == 0 && actualConstraintCount /= 0) (throwE (UnconstrainedSerializedConstraints actualConstraintCount))

    let distinctPointCount = Set.size (V.foldl' (flip Set.insert) Set.empty points)
    unless (distinctPointCount == vertexCount) (throwE (DuplicateSerializedCoordinates vertexCount distinctPointCount))

    let pointXStore = fromLocalVector 0 pointXs
        pointYStore = fromLocalVector 0 pointYs
        topologyStore =
          fromVector maxBound $
            U.generate (4 * halfCount) $ \slot ->
              let (edge, field) = slot `quotRem` 4
               in case field of
                    0 -> halfOrigin U.! edge
                    1 -> halfNext U.! edge
                    2 -> halfPrev U.! edge
                    _ -> halfFace U.! edge
        constraintEdgeIndex =
          U.ifoldl'
            (\edges index flag ->
               if flag == 1 then IntSet.insert index edges else edges
            )
            IntSet.empty
            constraints
    pure
      Triangulation
        { triPointX = pointXStore
        , triPointY = pointYStore
        , triPointIndex = buildPointIndex pointXStore pointYStore
        , triVertexOut = fromLocalVector maxBound vertexOut
        , triVertexData = boxedFromVector vertexDefault vertexDataVector
        , triHalfTopology = topologyStore
        , triDirectedData = boxedFromVector (Just (defaultDirectedEdgeData defaults)) directedDataVector
        , triUndirectedData = boxedFromVector (Just (defaultUndirectedEdgeData defaults)) undirectedDataVector
        , triFaceEdge = fromLocalVector maxBound faceEdge
        , triFaceData = boxedFromVector (Just (defaultFaceData defaults)) faceDataVector
        , triConstraint = fromVector 0 constraints
        , triConstraintCount = cachedConstraintCount
        , triConstraintEdges = constraintEdgeIndex
        , triElementDefaults = defaults
        }

validateStoredPoint :: Int -> Point -> Decoder ()
validateStoredPoint index point =
  case mkQueryPoint point of
    Left failure -> throwE (InvalidSerializedPoint index failure)
    Right _ -> pure ()

modeProxy :: Triangulation mode vertex directed undirected face -> Proxy mode
modeProxy _ = Proxy

modeTag :: ConstraintMode -> Word8
modeTag Unconstrained = 0
modeTag Constrained = 1

validateStructuralPrefix
  :: DecodingBudget
  -> Word64
  -> Word64
  -> Word64
  -> Word64
  -> Decoder ()
validateStructuralPrefix budget vertexCount directedEdgeCount faceCount constraintCount = do
  traverse_
    (uncurry validateEncodedCount)
    [ (SerializedVertexCount, vertexCount)
    , (SerializedDirectedEdgeCount, directedEdgeCount)
    , (SerializedFaceCount, faceCount)
    , (SerializedConstraintCount, constraintCount)
    ]
  unless (even directedEdgeCount) $
    throwE (SerializedDirectedEdgeCountOdd directedEdgeCount)
  unless (faceCount >= 1) (throwE SerializedMissingOuterFace)
  let undirectedEdgeCount = directedEdgeCount `quot` 2
  unless (constraintCount <= undirectedEdgeCount) $
    throwE
      ( SerializedConstraintCountExceedsEdges
          constraintCount
          undirectedEdgeCount
      )
  unless
    (planarCardinalityHolds vertexCount directedEdgeCount faceCount)
    ( throwE
        ( SerializedPlanarCardinalityMismatch
            vertexCount
            directedEdgeCount
            faceCount
        )
    )
  let sectionElements =
        4 * vertexCount
          + 6 * directedEdgeCount
          + 2 * faceCount
      maximumElements = decodingMaximumSectionElements budget
  when (sectionElements > maximumElements) $
    throwE (DecodedSectionBudgetExceeded sectionElements maximumElements)

validateEncodedCount :: SerializedCountKind -> Word64 -> Decoder ()
validateEncodedCount kind count = do
  when (count > fromIntegral (maxBound :: Int)) $
    throwE (EncodedCountExceedsInt kind count)
  when (count > maximumPackedElementCount) $
    throwE
      ( EncodedCountExceedsPackedIndex
          kind
          count
          maximumPackedElementCount
      )

-- Each resident handle is a Word32 with @maxBound@ withheld as the optional
-- no-index marker. A count may include every remaining representable handle.
maximumPackedElementCount :: Word64
maximumPackedElementCount = fromIntegral indexLimit + 1

-- Every resident triangulation is a connected planar straight-line graph.
-- Empty input has only the outer face; a bounded-face-free nonempty graph is the
-- collinear chain; otherwise Euler's law determines the edge count. All
-- arithmetic is safe after 'validateEncodedCount' bounds each term to the
-- packed-index domain.
planarCardinalityHolds :: Word64 -> Word64 -> Word64 -> Bool
planarCardinalityHolds vertexCount directedEdgeCount faceCount
  | vertexCount == 0 = directedEdgeCount == 0 && faceCount == 1
  | faceCount == 1 = directedEdgeCount == 2 * (vertexCount - 1)
  | vertexCount < 3 = False
  | otherwise =
      directedEdgeCount == 2 * (vertexCount + faceCount - 2)

-- The packed-index proof above bounds every term far below Word64 overflow.
-- Payloads and defaults have no format-level lower bound because lawful
-- 'Binary' decoders such as that for @()@ may consume zero bytes.
minimumFixedBodyBytes :: Word64 -> Word64 -> Word64 -> Word64
minimumFixedBodyBytes vertexCount directedEdgeCount faceCount =
  20 * vertexCount
    + 16 * directedEdgeCount
    + 4 * faceCount
    + directedEdgeCount `quot` 2