moonlight-triangulation-0.1.0.0: src-dual/Moonlight/Triangulation/Voronoi/Handles.hs

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

module Moonlight.Triangulation.Voronoi.Handles
  ( VoronoiFaceHandle
  , DirectedVoronoiEdgeHandle
  , UndirectedVoronoiEdgeHandle
  , VoronoiVertexHandle
  , voronoiFaceHandle
  , directedVoronoiEdgeHandle
  , undirectedVoronoiEdgeHandle
  , vertexAsVoronoiFaceH
  , directedEdgeAsVoronoiH
  , undirectedEdgeAsVoronoiH
  , innerFaceAsVoronoiVertexH
  , fixVoronoiFace
  , fixDirectedVoronoiEdge
  , fixUndirectedVoronoiEdge
  , fixVoronoiVertex
  , voronoiEdgeReverseH
  , voronoiEdgeNextH
  , voronoiEdgePreviousH
  , voronoiEdgeFromH
  , voronoiEdgeToH
  , voronoiEdgeFaceH
  , voronoiEdgeAsUndirectedH
  , voronoiEdgeAsDelaunayH
  , voronoiFaceSiteH
  , voronoiFaceAdjacentEdgesH
  , voronoiVertexPositionH
  , voronoiVertexOutEdgesH
  , voronoiVertexAsDelaunayFaceH
  , voronoiVertexAsOuterEdgeH
  , voronoiEdgeDirectionH
  , voronoiEdgeGeometryH
  ) where

import Moonlight.Triangulation.Handles.Dynamic
import Moonlight.Triangulation.Math (midpoint)
import Moonlight.Triangulation.Types
import Moonlight.Triangulation.Voronoi

-- | Zero-copy dual handles. Each dual value contains exactly one primal handle,
-- so it cannot accidentally combine an identifier from one triangulation with
-- the storage of another.
newtype VoronoiFaceHandle mode vertex directed undirected face =
  VoronoiFaceHandle (VertexHandle mode vertex directed undirected face)

newtype DirectedVoronoiEdgeHandle mode vertex directed undirected face =
  DirectedVoronoiEdgeHandle (DirectedEdgeHandle mode vertex directed undirected face)

newtype UndirectedVoronoiEdgeHandle mode vertex directed undirected face =
  UndirectedVoronoiEdgeHandle (UndirectedEdgeHandle mode vertex directed undirected face)

data VoronoiVertexHandle mode vertex directed undirected face
  = InnerVoronoiVertexHandle
      !(FaceHandle InnerTag mode vertex directed undirected face)
  | OuterVoronoiVertexHandle
      !(DirectedVoronoiEdgeHandle mode vertex directed undirected face)

instance Show (VoronoiFaceHandle mode vertex directed undirected face) where
  showsPrec precedence = showsPrec precedence . fixVoronoiFace

instance Show (DirectedVoronoiEdgeHandle mode vertex directed undirected face) where
  showsPrec precedence = showsPrec precedence . fixDirectedVoronoiEdge

instance Show (UndirectedVoronoiEdgeHandle mode vertex directed undirected face) where
  showsPrec precedence = showsPrec precedence . fixUndirectedVoronoiEdge

instance Show (VoronoiVertexHandle mode vertex directed undirected face) where
  showsPrec precedence = showsPrec precedence . fixVoronoiVertex

voronoiFaceHandle
  :: Triangulation mode vertex directed undirected face
  -> VoronoiFaceId
  -> Maybe (VoronoiFaceHandle mode vertex directed undirected face)
voronoiFaceHandle triangulation (VoronoiFaceId site) =
  VoronoiFaceHandle <$> vertexHandle triangulation site

vertexAsVoronoiFaceH
  :: VertexHandle mode vertex directed undirected face
  -> VoronoiFaceHandle mode vertex directed undirected face
vertexAsVoronoiFaceH = VoronoiFaceHandle

directedVoronoiEdgeHandle
  :: Triangulation mode vertex directed undirected face
  -> DirectedVoronoiEdgeId
  -> Maybe (DirectedVoronoiEdgeHandle mode vertex directed undirected face)
directedVoronoiEdgeHandle triangulation (DirectedVoronoiEdgeId edge) =
  DirectedVoronoiEdgeHandle <$> directedEdgeHandle triangulation edge

directedEdgeAsVoronoiH
  :: DirectedEdgeHandle mode vertex directed undirected face
  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face
directedEdgeAsVoronoiH = DirectedVoronoiEdgeHandle

undirectedVoronoiEdgeHandle
  :: Triangulation mode vertex directed undirected face
  -> UndirectedVoronoiEdgeId
  -> Maybe (UndirectedVoronoiEdgeHandle mode vertex directed undirected face)
undirectedVoronoiEdgeHandle triangulation (UndirectedVoronoiEdgeId edge) =
  UndirectedVoronoiEdgeHandle <$> undirectedEdgeHandle triangulation edge

undirectedEdgeAsVoronoiH
  :: UndirectedEdgeHandle mode vertex directed undirected face
  -> UndirectedVoronoiEdgeHandle mode vertex directed undirected face
undirectedEdgeAsVoronoiH = UndirectedVoronoiEdgeHandle

innerFaceAsVoronoiVertexH
  :: FaceHandle InnerTag mode vertex directed undirected face
  -> VoronoiVertexHandle mode vertex directed undirected face
innerFaceAsVoronoiVertexH = InnerVoronoiVertexHandle

fixVoronoiFace :: VoronoiFaceHandle mode vertex directed undirected face -> VoronoiFaceId
fixVoronoiFace (VoronoiFaceHandle site) = VoronoiFaceId (fixVertex site)
{-# INLINE fixVoronoiFace #-}

fixDirectedVoronoiEdge
  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> DirectedVoronoiEdgeId
fixDirectedVoronoiEdge (DirectedVoronoiEdgeHandle edge) =
  DirectedVoronoiEdgeId (fixDirectedEdge edge)
{-# INLINE fixDirectedVoronoiEdge #-}

fixUndirectedVoronoiEdge
  :: UndirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> UndirectedVoronoiEdgeId
fixUndirectedVoronoiEdge (UndirectedVoronoiEdgeHandle edge) =
  UndirectedVoronoiEdgeId (fixUndirectedEdge edge)
{-# INLINE fixUndirectedVoronoiEdge #-}

fixVoronoiVertex
  :: VoronoiVertexHandle mode vertex directed undirected face
  -> VoronoiVertexId
fixVoronoiVertex (InnerVoronoiVertexHandle face) =
  InnerVoronoiVertex (fixedFaceId (fixFace face))
fixVoronoiVertex (OuterVoronoiVertexHandle edge) =
  OuterVoronoiVertex (fixDirectedVoronoiEdge edge)
{-# INLINE fixVoronoiVertex #-}

voronoiEdgeReverseH
  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face
voronoiEdgeReverseH (DirectedVoronoiEdgeHandle edge) =
  DirectedVoronoiEdgeHandle (directedEdgeReverse edge)

voronoiEdgeNextH
  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face
voronoiEdgeNextH (DirectedVoronoiEdgeHandle edge) =
  DirectedVoronoiEdgeHandle (directedEdgeCounterClockwise edge)

voronoiEdgePreviousH
  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face
voronoiEdgePreviousH (DirectedVoronoiEdgeHandle edge) =
  DirectedVoronoiEdgeHandle (directedEdgeClockwise edge)

voronoiEdgeFromH
  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> VoronoiVertexHandle mode vertex directed undirected face
voronoiEdgeFromH edge@(DirectedVoronoiEdgeHandle primal) =
  case faceAsInner (directedEdgeFace primal) of
    Just inner -> InnerVoronoiVertexHandle inner
    Nothing -> OuterVoronoiVertexHandle edge

voronoiEdgeToH
  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> VoronoiVertexHandle mode vertex directed undirected face
voronoiEdgeToH = voronoiEdgeFromH . voronoiEdgeReverseH

voronoiEdgeFaceH
  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> VoronoiFaceHandle mode vertex directed undirected face
voronoiEdgeFaceH (DirectedVoronoiEdgeHandle edge) =
  VoronoiFaceHandle (directedEdgeFrom edge)

voronoiEdgeAsUndirectedH
  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> UndirectedVoronoiEdgeHandle mode vertex directed undirected face
voronoiEdgeAsUndirectedH (DirectedVoronoiEdgeHandle edge) =
  UndirectedVoronoiEdgeHandle (directedEdgeAsUndirected edge)

voronoiEdgeAsDelaunayH
  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> DirectedEdgeHandle mode vertex directed undirected face
voronoiEdgeAsDelaunayH (DirectedVoronoiEdgeHandle edge) = edge

voronoiFaceSiteH
  :: VoronoiFaceHandle mode vertex directed undirected face
  -> VertexHandle mode vertex directed undirected face
voronoiFaceSiteH (VoronoiFaceHandle site) = site

voronoiFaceAdjacentEdgesH
  :: VoronoiFaceHandle mode vertex directed undirected face
  -> [DirectedVoronoiEdgeHandle mode vertex directed undirected face]
voronoiFaceAdjacentEdgesH (VoronoiFaceHandle site) =
  map DirectedVoronoiEdgeHandle (vertexHandleOutEdges site)

voronoiVertexPositionH
  :: VoronoiVertexHandle mode vertex directed undirected face
  -> Maybe (Point)
voronoiVertexPositionH (InnerVoronoiVertexHandle face) = innerFaceCircumcenter face
voronoiVertexPositionH (OuterVoronoiVertexHandle _) = Nothing

voronoiVertexOutEdgesH
  :: VoronoiVertexHandle mode vertex directed undirected face
  -> Maybe [DirectedVoronoiEdgeHandle mode vertex directed undirected face]
voronoiVertexOutEdgesH (InnerVoronoiVertexHandle face) =
  Just (map DirectedVoronoiEdgeHandle (faceAdjacentEdges face))
voronoiVertexOutEdgesH (OuterVoronoiVertexHandle _) = Nothing

voronoiVertexAsDelaunayFaceH
  :: VoronoiVertexHandle mode vertex directed undirected face
  -> Maybe (FaceHandle InnerTag mode vertex directed undirected face)
voronoiVertexAsDelaunayFaceH (InnerVoronoiVertexHandle face) = Just face
voronoiVertexAsDelaunayFaceH (OuterVoronoiVertexHandle _) = Nothing

voronoiVertexAsOuterEdgeH
  :: VoronoiVertexHandle mode vertex directed undirected face
  -> Maybe (DirectedVoronoiEdgeHandle mode vertex directed undirected face)
voronoiVertexAsOuterEdgeH (InnerVoronoiVertexHandle _) = Nothing
voronoiVertexAsOuterEdgeH (OuterVoronoiVertexHandle edge) = Just edge

voronoiEdgeDirectionH
  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> Point
voronoiEdgeDirectionH (DirectedVoronoiEdgeHandle primal) =
  let (Point ax ay, Point bx by) = directedEdgePositions primal
   in Point (ay - by) (bx - ax)

voronoiEdgeGeometryH
  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face
  -> Maybe (VoronoiEdgeGeometry)
voronoiEdgeGeometryH edge@(DirectedVoronoiEdgeHandle primal) =
  case (voronoiEdgeFromH edge, voronoiEdgeToH edge) of
    (InnerVoronoiVertexHandle fromFace, InnerVoronoiVertexHandle toFace) ->
      VoronoiSegment <$> innerFaceCircumcenter fromFace <*> innerFaceCircumcenter toFace
    (InnerVoronoiVertexHandle fromFace, OuterVoronoiVertexHandle _) -> do
      start <- innerFaceCircumcenter fromFace
      pure (VoronoiRay start (normalizePoint (voronoiEdgeDirectionH edge)))
    (OuterVoronoiVertexHandle _, InnerVoronoiVertexHandle toFace) -> do
      end <- innerFaceCircumcenter toFace
      pure (VoronoiRay end (normalizePoint (negatePoint (voronoiEdgeDirectionH edge))))
    (OuterVoronoiVertexHandle _, OuterVoronoiVertexHandle _) ->
      let (from, to) = directedEdgePositions primal
       in Just (VoronoiLine (midpoint from to) (normalizePoint (voronoiEdgeDirectionH edge)))

normalizePoint :: Point -> Point
normalizePoint (Point x y)
  | scale == 0 = Point 0 0
  | otherwise =
      let !scaledX = x / scale
          !scaledY = y / scale
          !length' = sqrt (scaledX * scaledX + scaledY * scaledY)
       in Point (scaledX / length') (scaledY / length')
 where
  !scale = max (abs x) (abs y)

negatePoint :: Point -> Point
negatePoint (Point x y) = Point (-x) (-y)

-- The handle verbs cross the same component boundary as the fixed-index ones
-- and carry their unfoldings for the same reason. 'voronoiVertexPositionH'
-- reaches its arithmetic through 'innerFaceCircumcenter', whose own worker
-- publishes no unfolding, so it stops at that call until the dcel layer says
-- otherwise.