{-# LANGUAGE ScopedTypeVariables #-}
module Algorithms.Geometry.PolygonTriangulation.Types where
import Control.Lens
import Control.Monad (forM_)
import Data.Ext
import qualified Data.Foldable as F
import Data.Geometry.LineSegment
import Data.Geometry.PlanarSubdivision.Basic
import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.PlaneGraph as PG
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
data PolygonEdgeType = Original | Diagonal
deriving (Int -> PolygonEdgeType -> ShowS
[PolygonEdgeType] -> ShowS
PolygonEdgeType -> String
(Int -> PolygonEdgeType -> ShowS)
-> (PolygonEdgeType -> String)
-> ([PolygonEdgeType] -> ShowS)
-> Show PolygonEdgeType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PolygonEdgeType] -> ShowS
$cshowList :: [PolygonEdgeType] -> ShowS
show :: PolygonEdgeType -> String
$cshow :: PolygonEdgeType -> String
showsPrec :: Int -> PolygonEdgeType -> ShowS
$cshowsPrec :: Int -> PolygonEdgeType -> ShowS
Show,ReadPrec [PolygonEdgeType]
ReadPrec PolygonEdgeType
Int -> ReadS PolygonEdgeType
ReadS [PolygonEdgeType]
(Int -> ReadS PolygonEdgeType)
-> ReadS [PolygonEdgeType]
-> ReadPrec PolygonEdgeType
-> ReadPrec [PolygonEdgeType]
-> Read PolygonEdgeType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PolygonEdgeType]
$creadListPrec :: ReadPrec [PolygonEdgeType]
readPrec :: ReadPrec PolygonEdgeType
$creadPrec :: ReadPrec PolygonEdgeType
readList :: ReadS [PolygonEdgeType]
$creadList :: ReadS [PolygonEdgeType]
readsPrec :: Int -> ReadS PolygonEdgeType
$creadsPrec :: Int -> ReadS PolygonEdgeType
Read,PolygonEdgeType -> PolygonEdgeType -> Bool
(PolygonEdgeType -> PolygonEdgeType -> Bool)
-> (PolygonEdgeType -> PolygonEdgeType -> Bool)
-> Eq PolygonEdgeType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PolygonEdgeType -> PolygonEdgeType -> Bool
$c/= :: PolygonEdgeType -> PolygonEdgeType -> Bool
== :: PolygonEdgeType -> PolygonEdgeType -> Bool
$c== :: PolygonEdgeType -> PolygonEdgeType -> Bool
Eq)
constructSubdivision :: forall proxy r s p. (Fractional r, Ord r)
=> proxy s
-> LineSegment 2 p r
-> [LineSegment 2 p r]
-> [LineSegment 2 p r]
-> PlanarSubdivision s
p PolygonEdgeType PolygonFaceData r
constructSubdivision :: proxy s
-> LineSegment 2 p r
-> [LineSegment 2 p r]
-> [LineSegment 2 p r]
-> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r
constructSubdivision proxy s
px LineSegment 2 p r
e [LineSegment 2 p r]
origs [LineSegment 2 p r]
diags = PlaneGraph s p PolygonEdgeType PolygonFaceData r
-> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r
forall k (s :: k) v e f r.
(Ord r, Fractional r) =>
PlaneGraph s v e f r -> PlanarSubdivision s v e f r
fromPlaneGraph (PlaneGraph s p PolygonEdgeType PolygonFaceData r
-> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r)
-> PlaneGraph s p PolygonEdgeType PolygonFaceData r
-> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r
forall a b. (a -> b) -> a -> b
$ proxy s
-> LineSegment 2 p r
-> [LineSegment 2 p r]
-> [LineSegment 2 p r]
-> PlaneGraph s p PolygonEdgeType PolygonFaceData r
forall k (proxy :: k -> *) r (s :: k) p.
(Fractional r, Ord r) =>
proxy s
-> LineSegment 2 p r
-> [LineSegment 2 p r]
-> [LineSegment 2 p r]
-> PlaneGraph s p PolygonEdgeType PolygonFaceData r
constructGraph proxy s
px LineSegment 2 p r
e [LineSegment 2 p r]
origs [LineSegment 2 p r]
diags
constructGraph :: forall proxy r s p. (Fractional r, Ord r)
=> proxy s
-> LineSegment 2 p r
-> [LineSegment 2 p r]
-> [LineSegment 2 p r]
-> PG.PlaneGraph s
p PolygonEdgeType PolygonFaceData r
constructGraph :: proxy s
-> LineSegment 2 p r
-> [LineSegment 2 p r]
-> [LineSegment 2 p r]
-> PlaneGraph s p PolygonEdgeType PolygonFaceData r
constructGraph proxy s
px LineSegment 2 p r
e [LineSegment 2 p r]
origs [LineSegment 2 p r]
diags =
PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
subdiv PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> (PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> PlaneGraph s p (Bool, PolygonEdgeType) () r)
-> PlaneGraph s p (Bool, PolygonEdgeType) () r
forall a b. a -> (a -> b) -> b
& (Vector (NonEmpty p) -> Identity (Vector p))
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> Identity (PlaneGraph s p (Bool, PolygonEdgeType) () r)
forall k (s :: k) v e f r v'.
Lens
(PlaneGraph s v e f r)
(PlaneGraph s v' e f r)
(Vector v)
(Vector v')
PG.vertexData((Vector (NonEmpty p) -> Identity (Vector p))
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> Identity (PlaneGraph s p (Bool, PolygonEdgeType) () r))
-> ((NonEmpty p -> Identity p)
-> Vector (NonEmpty p) -> Identity (Vector p))
-> (NonEmpty p -> Identity p)
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> Identity (PlaneGraph s p (Bool, PolygonEdgeType) () r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(NonEmpty p -> Identity p)
-> Vector (NonEmpty p) -> Identity (Vector p)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((NonEmpty p -> Identity p)
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> Identity (PlaneGraph s p (Bool, PolygonEdgeType) () r))
-> (NonEmpty p -> p)
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> PlaneGraph s p (Bool, PolygonEdgeType) () r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ NonEmpty p -> p
forall a. NonEmpty a -> a
NonEmpty.head
PlaneGraph s p (Bool, PolygonEdgeType) () r
-> (PlaneGraph s p (Bool, PolygonEdgeType) () r
-> PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r)
-> PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r
forall a b. a -> (a -> b) -> b
& (Vector () -> Identity (Vector PolygonFaceData))
-> PlaneGraph s p (Bool, PolygonEdgeType) () r
-> Identity
(PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r)
forall k (s :: k) v e f r f'.
Lens
(PlaneGraph s v e f r)
(PlaneGraph s v e f' r)
(Vector f)
(Vector f')
PG.faceData ((Vector () -> Identity (Vector PolygonFaceData))
-> PlaneGraph s p (Bool, PolygonEdgeType) () r
-> Identity
(PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r))
-> Vector PolygonFaceData
-> PlaneGraph s p (Bool, PolygonEdgeType) () r
-> PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Vector PolygonFaceData
faceData'
PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r
-> (PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r
-> PlaneGraph s p PolygonEdgeType PolygonFaceData r)
-> PlaneGraph s p PolygonEdgeType PolygonFaceData r
forall a b. a -> (a -> b) -> b
& (Vector (Bool, PolygonEdgeType)
-> Identity (Vector PolygonEdgeType))
-> PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r
-> Identity (PlaneGraph s p PolygonEdgeType PolygonFaceData r)
forall k (s :: k) v e f r e'.
Lens
(PlaneGraph s v e f r)
(PlaneGraph s v e' f r)
(Vector e)
(Vector e')
PG.rawDartData((Vector (Bool, PolygonEdgeType)
-> Identity (Vector PolygonEdgeType))
-> PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r
-> Identity (PlaneGraph s p PolygonEdgeType PolygonFaceData r))
-> (((Bool, PolygonEdgeType) -> Identity PolygonEdgeType)
-> Vector (Bool, PolygonEdgeType)
-> Identity (Vector PolygonEdgeType))
-> ((Bool, PolygonEdgeType) -> Identity PolygonEdgeType)
-> PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r
-> Identity (PlaneGraph s p PolygonEdgeType PolygonFaceData r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Bool, PolygonEdgeType) -> Identity PolygonEdgeType)
-> Vector (Bool, PolygonEdgeType)
-> Identity (Vector PolygonEdgeType)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Bool, PolygonEdgeType) -> Identity PolygonEdgeType)
-> PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r
-> Identity (PlaneGraph s p PolygonEdgeType PolygonFaceData r))
-> ((Bool, PolygonEdgeType) -> PolygonEdgeType)
-> PlaneGraph s p (Bool, PolygonEdgeType) PolygonFaceData r
-> PlaneGraph s p PolygonEdgeType PolygonFaceData r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Bool, PolygonEdgeType) -> PolygonEdgeType
forall a b. (a, b) -> b
snd
where
subdiv :: PG.PlaneGraph s (NonEmpty p) (Bool,PolygonEdgeType) () r
subdiv :: PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
subdiv = proxy s
-> [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
forall k (f :: * -> *) r (proxy :: k -> *) (s :: k) p e.
(Foldable f, Ord r, Num r) =>
proxy s
-> f (LineSegment 2 p r :+ e) -> PlaneGraph s (NonEmpty p) e () r
PG.fromConnectedSegments proxy s
px ([LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r)
-> [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
forall a b. (a -> b) -> a -> b
$ LineSegment 2 p r :+ (Bool, PolygonEdgeType)
e' (LineSegment 2 p r :+ (Bool, PolygonEdgeType))
-> [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
-> [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
forall a. a -> [a] -> [a]
: [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
origs' [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
-> [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
-> [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
forall a. Semigroup a => a -> a -> a
<> [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
diags'
diags' :: [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
diags' = (LineSegment 2 p r
-> (Bool, PolygonEdgeType)
-> LineSegment 2 p r :+ (Bool, PolygonEdgeType)
forall core extra. core -> extra -> core :+ extra
:+ (Bool
True, PolygonEdgeType
Diagonal)) (LineSegment 2 p r -> LineSegment 2 p r :+ (Bool, PolygonEdgeType))
-> [LineSegment 2 p r]
-> [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LineSegment 2 p r]
diags
origs' :: [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
origs' = (LineSegment 2 p r
-> (Bool, PolygonEdgeType)
-> LineSegment 2 p r :+ (Bool, PolygonEdgeType)
forall core extra. core -> extra -> core :+ extra
:+ (Bool
False,PolygonEdgeType
Original)) (LineSegment 2 p r -> LineSegment 2 p r :+ (Bool, PolygonEdgeType))
-> [LineSegment 2 p r]
-> [LineSegment 2 p r :+ (Bool, PolygonEdgeType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LineSegment 2 p r]
origs
e' :: LineSegment 2 p r :+ (Bool, PolygonEdgeType)
e' = LineSegment 2 p r
e LineSegment 2 p r
-> (Bool, PolygonEdgeType)
-> LineSegment 2 p r :+ (Bool, PolygonEdgeType)
forall core extra. core -> extra -> core :+ extra
:+ (Bool
True, PolygonEdgeType
Original)
queryDarts :: [Dart s]
queryDarts = (Dart s -> [Dart s]) -> [Dart s] -> [Dart s]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Dart s -> [Dart s]
shouldQuery ([Dart s] -> [Dart s])
-> (PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> [Dart s])
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> [Dart s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Dart s) -> [Dart s]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Vector (Dart s) -> [Dart s])
-> (PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> Vector (Dart s))
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> [Dart s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> Vector (Dart s)
forall k (s :: k) v e f r. PlaneGraph s v e f r -> Vector (Dart s)
PG.edges' (PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> [Dart s])
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> [Dart s]
forall a b. (a -> b) -> a -> b
$ PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
subdiv
shouldQuery :: Dart s -> [Dart s]
shouldQuery Dart s
d = case PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
subdivPlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> Getting
(Bool, PolygonEdgeType)
(PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r)
(Bool, PolygonEdgeType)
-> (Bool, PolygonEdgeType)
forall s a. s -> Getting a s a -> a
^.Dart s
-> Lens'
(PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r)
(DataOf
(PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r) (Dart s))
forall g i. HasDataOf g i => i -> Lens' g (DataOf g i)
dataOf Dart s
d of
(Bool
True, PolygonEdgeType
Original) -> [Dart s
d]
(Bool
True, PolygonEdgeType
Diagonal) -> [Dart s
d, Dart s -> Dart s
forall k (s :: k). Dart s -> Dart s
twin Dart s
d]
(Bool, PolygonEdgeType)
_ -> []
intFaces :: [FaceId' s]
intFaces = (Dart s
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> FaceId' s)
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> Dart s
-> FaceId' s
forall a b c. (a -> b -> c) -> b -> a -> c
flip Dart s
-> PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
-> FaceId' s
forall k (s :: k) v e f r.
Dart s -> PlaneGraph s v e f r -> FaceId' s
PG.leftFace PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
subdiv (Dart s -> FaceId' s) -> [Dart s] -> [FaceId' s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Dart s]
queryDarts
faceData' :: V.Vector PolygonFaceData
faceData' :: Vector PolygonFaceData
faceData' = (forall s. ST s (MVector s PolygonFaceData))
-> Vector PolygonFaceData
forall a. (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s PolygonFaceData))
-> Vector PolygonFaceData)
-> (forall s. ST s (MVector s PolygonFaceData))
-> Vector PolygonFaceData
forall a b. (a -> b) -> a -> b
$ do
MVector s PolygonFaceData
v' <- Int
-> PolygonFaceData
-> ST s (MVector (PrimState (ST s)) PolygonFaceData)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
MV.replicate (PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r -> Int
forall k (s :: k) v e f r. PlaneGraph s v e f r -> Int
PG.numFaces PlaneGraph s (NonEmpty p) (Bool, PolygonEdgeType) () r
subdiv) PolygonFaceData
Outside
[FaceId' s] -> (FaceId' s -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FaceId' s]
intFaces ((FaceId' s -> ST s ()) -> ST s ())
-> (FaceId' s -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(PG.FaceId (PG.VertexId Int
f)) ->
MVector (PrimState (ST s)) PolygonFaceData
-> Int -> PolygonFaceData -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s PolygonFaceData
MVector (PrimState (ST s)) PolygonFaceData
v' Int
f PolygonFaceData
Inside
MVector s PolygonFaceData -> ST s (MVector s PolygonFaceData)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVector s PolygonFaceData
v'