FloodFillIterator.hs

{-# LANGUAGE FlexibleInstances #-}

-- | Shape queries and face flood fills over immutable triangulations.
module Moonlight.Triangulation.FloodFillIterator
  ( DistanceMetric (..)
  , CircleMetric
  , CircleMetricError (..)
  , RectangleMetric
  , RectangleMetricError (..)
  , circleMetric
  , rectangleMetric
  , edgesInShape
  , verticesInShape
  , edgesInCircle
  , verticesInCircle
  , edgesInRectangle
  , verticesInRectangle
  , floodFillFaces
  , outerFaceFloodFill
  , facesAtEvenBarrierDepth
  ) where

import qualified Data.IntSet as IntSet
import Moonlight.Triangulation.Dcel
import Moonlight.Triangulation.Handles.HandleDefs
import Moonlight.Triangulation.Handles.Iterators.FixedIterators (undirectedEdges)
import Moonlight.Triangulation.Math
import Moonlight.Triangulation.PointLocation
import Moonlight.Triangulation.Types

-- | A query shape that can admit points, test edges, and supply a location
-- seed.
class DistanceMetric metric where
  metricContainsPoint :: metric -> Point -> Bool
  metricIntersectsEdge :: metric -> Point -> Point -> Bool
  metricStartPoint :: metric -> QueryPoint

-- | An admitted center and squared radius.
data CircleMetric = CircleMetric !(QueryPoint) !Double
  deriving stock (Eq, Ord, Show)

-- | Typed refusal for an invalid circle query.
data CircleMetricError
  = InvalidCircleCenter !PointValidationError
  | NonFiniteRadiusSquared !NonFiniteValue
  | NegativeRadiusSquared !Double
  deriving stock (Eq, Ord, Show)

-- | Admitted lower corner, upper corner, and center of an axis-aligned box.
data RectangleMetric = RectangleMetric !(QueryPoint) !(QueryPoint) !(QueryPoint)
  deriving stock (Eq, Ord, Show)

-- | Typed refusal for an invalid rectangle query.
data RectangleMetricError
  = InvalidRectangleLower !PointValidationError
  | InvalidRectangleUpper !PointValidationError
  | InvalidRectangleCenter !PointValidationError
  deriving stock (Eq, Ord, Show)

-- | A circle metric, or why the radius is unusable.
circleMetric :: Point -> Double -> Either CircleMetricError CircleMetric
circleMetric center radiusSquared = do
  queryCenter <- either (Left . InvalidCircleCenter) Right (mkQueryPoint center)
  case classifyNonFinite radiusSquared of
    Just nonFinite -> Left (NonFiniteRadiusSquared nonFinite)
    Nothing
      | radiusSquared < 0 -> Left (NegativeRadiusSquared radiusSquared)
      | otherwise -> Right (CircleMetric queryCenter radiusSquared)

-- | An axis-aligned rectangle metric, or why the corners are unusable.
rectangleMetric :: Point -> Point -> Either RectangleMetricError RectangleMetric
rectangleMetric lower@(Point lowerX lowerY) upper@(Point upperX upperY) = do
  queryLower <- either (Left . InvalidRectangleLower) Right (mkQueryPoint lower)
  queryUpper <- either (Left . InvalidRectangleUpper) Right (mkQueryPoint upper)
  queryCenter <-
    either
      (Left . InvalidRectangleCenter)
      Right
      (mkQueryPoint (Point ((lowerX + upperX) * 0.5) ((lowerY + upperY) * 0.5)))
  Right (RectangleMetric queryLower queryUpper queryCenter)

instance DistanceMetric CircleMetric where
  metricContainsPoint (CircleMetric center radiusSquared) point =
    squaredDistanceWide (queryPointValue center) point <= radiusSquared
  metricIntersectsEdge (CircleMetric center radiusSquared) from to =
    segmentDistanceSquaredWide from to (queryPointValue center) <= radiusSquared
  metricStartPoint (CircleMetric center _) = center

instance DistanceMetric RectangleMetric where
  metricContainsPoint (RectangleMetric lower upper _) (Point x y) =
    lowerX <= upperX && lowerY <= upperY && x >= lowerX && x <= upperX && y >= lowerY && y <= upperY
   where
    Point lowerX lowerY = queryPointValue lower
    Point upperX upperY = queryPointValue upper
  metricIntersectsEdge rectangle from to =
    metricContainsPoint rectangle from
      || metricContainsPoint rectangle to
      || segmentRectangleIntersection rectangle from to
  metricStartPoint (RectangleMetric _ _ center) = center

-- | Edges meeting a circle.
edgesInCircle :: Triangulation mode vertex directed undirected face -> Point -> Double -> Either CircleMetricError [UndirectedEdgeId]
edgesInCircle triangulation center radiusSquared =
  edgesInShape triangulation <$> circleMetric center radiusSquared

-- | Vertices inside a circle.
verticesInCircle :: Triangulation mode vertex directed undirected face -> Point -> Double -> Either CircleMetricError [VertexId]
verticesInCircle triangulation center radiusSquared =
  verticesInShape triangulation <$> circleMetric center radiusSquared

-- | Edges meeting an axis-aligned rectangle.
edgesInRectangle :: Triangulation mode vertex directed undirected face -> Point -> Point -> Either RectangleMetricError [UndirectedEdgeId]
edgesInRectangle triangulation lower upper = edgesInShape triangulation <$> rectangleMetric lower upper

-- | Vertices inside an axis-aligned rectangle.
verticesInRectangle :: Triangulation mode vertex directed undirected face -> Point -> Point -> Either RectangleMetricError [VertexId]
verticesInRectangle triangulation lower upper = verticesInShape triangulation <$> rectangleMetric lower upper

-- | Edges meeting any metric shape.
edgesInShape :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [UndirectedEdgeId]
edgesInShape triangulation metric
  | numVertices triangulation <= 1 = []
  | numInnerFaces triangulation == 0 =
      [edge | edge <- undirectedEdges triangulation, edgeInside edge]
  | otherwise =
      let starts = shapeStartFaces triangulation metric
          (_, accepted) = floodFillFacesWithEdges triangulation starts edgeInside
       in map (UndirectedEdgeId . fromIntegral) (IntSet.toAscList accepted)
 where
  edgeInside edge =
    let (fromVertex, toVertex) = undirectedEndpoints triangulation edge
     in metricIntersectsEdge metric (vertexPoint triangulation fromVertex) (vertexPoint triangulation toVertex)

-- | Vertices inside any metric shape.
verticesInShape :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [VertexId]
verticesInShape triangulation metric =
  [ vertex
  | vertex <- candidateVertices
  , metricContainsPoint metric (vertexPoint triangulation vertex)
  ]
 where
  edges = edgesInShape triangulation metric
  set = foldl' addEndpoints IntSet.empty edges
  addEndpoints acc edge =
    let (VertexId from, VertexId to) = undirectedEndpoints triangulation edge
     in IntSet.insert (fromIntegral from) (IntSet.insert (fromIntegral to) acc)
  candidateVertices
    | numVertices triangulation == 1 = [VertexId 0]
    | otherwise = map (VertexId . fromIntegral) (IntSet.toAscList set)

-- | Reach inner faces from the supplied seeds by crossing only admitted edges.
floodFillFaces
  :: Triangulation mode vertex directed undirected face -> [FaceId]
  -> (UndirectedEdgeId -> Bool)
  -> [FaceId]
floodFillFaces triangulation starts canCross =
  fst (floodFillFacesWithEdges triangulation starts canCross)

floodFillFacesWithEdges
  :: Triangulation mode vertex directed undirected face -> [FaceId]
  -> (UndirectedEdgeId -> Bool)
  -> ([FaceId], IntSet.IntSet)
floodFillFacesWithEdges triangulation starts canCross =
  let (faces, accepted, _) = go initialStack initialVisited IntSet.empty IntSet.empty []
   in (reverse faces, accepted)
 where
  valid face@(FaceId value) = face /= outerFace && fromIntegral value < numFaces triangulation
  (initialStack, initialVisited) = foldl' enqueueStart ([], IntSet.empty) starts

  enqueueStart state face
    | valid face = enqueue face state
    | otherwise = state

  go [] _ accepted rejected result = (result, accepted, rejected)
  go (face : stack) visited accepted rejected result =
    let (stack', visited', accepted', rejected') =
          foldl' expand (stack, visited, accepted, rejected) (faceDirectedEdges triangulation face)
     in go stack' visited' accepted' rejected' (face : result)

  expand (stack, visited, accepted, rejected) edge =
    let undirected@(UndirectedEdgeId raw) = asUndirected edge
        edgeIndex = fromIntegral raw
        adjacent = incidentFace triangulation (reverseEdge edge)
        edgeAdmission
          | IntSet.member edgeIndex accepted = (True, accepted, rejected)
          | IntSet.member edgeIndex rejected = (False, accepted, rejected)
          | canCross undirected = (True, IntSet.insert edgeIndex accepted, rejected)
          | otherwise = (False, accepted, IntSet.insert edgeIndex rejected)
        (crosses, accepted', rejected') = edgeAdmission
        (stack', visited') =
          if crosses && valid adjacent
            then enqueue adjacent (stack, visited)
            else (stack, visited)
     in (stack', visited', accepted', rejected')

  enqueue face@(FaceId value) (stack, visited)
    | IntSet.member index visited = (stack, visited)
    | otherwise = (face : stack, IntSet.insert index visited)
   where
    index = fromIntegral value

-- | Inner faces separated from the outer face by an even minimum number of
-- barriers. A 0–1 BFS floods freely within one depth before crossing a barrier,
-- so a free-ended barrier can be walked around at depth zero while nested
-- closed barriers alternate outside and inside.
facesAtEvenBarrierDepth
  :: Triangulation mode vertex directed undirected face
  -> (UndirectedEdgeId -> Bool)
  -> [FaceId]
facesAtEvenBarrierDepth triangulation isBarrier =
  concat (evenLayers (barrierDepthLayers triangulation isBarrier))
 where
  evenLayers :: [[FaceId]] -> [[FaceId]]
  evenLayers (outsideLayer : _insideLayer : deeper) =
    outsideLayer : evenLayers deeper
  evenLayers shallow = shallow

barrierDepthLayers
  :: Triangulation mode vertex directed undirected face
  -> (UndirectedEdgeId -> Bool)
  -> [[FaceId]]
barrierDepthLayers triangulation isBarrier =
  map (filter (/= outerFace)) (layers IntSet.empty [outerFace])
 where
  known (FaceId value) = fromIntegral value < numFaces triangulation
  key :: FaceId -> Int
  key (FaceId value) = fromIntegral value

  layers visited frontier = case flood visited [] frontier of
    ([], _) -> []
    (layer, visited') -> layer : layers visited' (concatMap (neighbours isBarrier) layer)

  flood visited acc [] = (reverse acc, visited)
  flood visited acc (face : rest)
    | not (known face) || IntSet.member (key face) visited = flood visited acc rest
    | otherwise =
        flood
          (IntSet.insert (key face) visited)
          (face : acc)
          (neighbours (not . isBarrier) face <> rest)

  neighbours admit face =
    [ incidentFace triangulation (reverseEdge edge)
    | edge <- faceDirectedEdges triangulation face
    , admit (asUndirected edge)
    ]

-- | Faces reachable from the outer face without crossing a barrier edge.
outerFaceFloodFill :: Triangulation mode vertex directed undirected face -> (UndirectedEdgeId -> Bool) -> [FaceId]
outerFaceFloodFill triangulation canCross = floodFillFaces triangulation starts canCross
 where
  starts =
    [ face
    | outerEdge <- faceDirectedEdges triangulation outerFace
    , let edge = asUndirected outerEdge
    , canCross edge
    , let face = incidentFace triangulation (reverseEdge outerEdge)
    , face /= outerFace
    ]

-- | The faces a shape's start point lands in.
shapeStartFaces :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [FaceId]
shapeStartFaces triangulation metric =
  case locatePoint triangulation (metricStartPoint metric) of
    InFace face -> [face]
    OnEdge edge -> filter (/= outerFace) [incidentFace triangulation edge, incidentFace triangulation (reverseEdge edge)]
    OnVertex vertex ->
      intSetToFaces
        (foldl' (\set edge -> let FaceId value = incidentFace triangulation edge in if value == 0 then set else IntSet.insert (fromIntegral value) set) IntSet.empty (vertexOutgoingEdges triangulation vertex))
    OutsideConvexHull _ ->
      [ incidentFace triangulation (reverseEdge edge)
      | edge <- faceDirectedEdges triangulation outerFace
      , let from = vertexPoint triangulation (origin triangulation edge)
      , let to = vertexPoint triangulation (destination triangulation edge)
      , metricIntersectsEdge metric from to
      , incidentFace triangulation (reverseEdge edge) /= outerFace
      ]
    EmptyTriangulation -> []
 where
  intSetToFaces = map (FaceId . fromIntegral) . IntSet.toAscList

segmentRectangleIntersection :: RectangleMetric -> Point -> Point -> Bool
segmentRectangleIntersection (RectangleMetric lowerQuery upperQuery _) from to
  | lx > ux || ly > uy = False
  | lower == upper = onClosedSegment from to lower
  | otherwise = any (uncurry (segmentsIntersect from to)) boundaries
 where
  lower@(Point lx ly) = queryPointValue lowerQuery
  upper@(Point ux uy) = queryPointValue upperQuery
  boundaries =
    [ (Point lx ly, Point lx uy)
    , (Point lx uy, Point ux uy)
    , (Point ux uy, Point ux ly)
    , (Point ux ly, Point lx ly)
    ]