{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Geometry.PlanarSubdivision.Basic( VertexId', FaceId'
, VertexData(VertexData), PG.vData, PG.location
, FaceData(FaceData), holes, fData
, PlanarSubdivision(PlanarSubdivision)
, Wrap
, Component, ComponentId
, PolygonFaceData(..)
, PlanarGraph
, PlaneGraph
, fromSimplePolygon
, fromConnectedSegments
, fromPlaneGraph, fromPlaneGraph'
, numComponents, numVertices
, numEdges, numFaces, numDarts
, dual
, components, component
, vertices', vertices
, edges', edges
, faces', faces, internalFaces
, darts'
, headOf, tailOf, twin, endPoints
, incidentEdges, incomingEdges, outgoingEdges
, nextIncidentEdge
, neighboursOf
, leftFace, rightFace
, outerBoundaryDarts, boundaryVertices, holesOf
, outerFaceId
, boundary'
, locationOf
, HasDataOf(..)
, endPointsOf, endPointData
, faceDataOf
, edgeSegment, edgeSegments
, rawFacePolygon, rawFaceBoundary
, rawFacePolygons
, VertexId(..), FaceId(..), Dart, World(..)
, rawVertexData, rawDartData, rawFaceData
, vertexData, dartData, faceData
, dataVal
, dartMapping, Raw(..)
) where
import Control.Lens hiding (holes, holesOf, (.=))
import Data.Coerce
import Data.Ext
import qualified Data.Foldable as F
import Data.Geometry.Box
import Data.Geometry.LineSegment hiding (endPoints)
import Data.Geometry.PlanarSubdivision.Raw
import Data.Geometry.Point
import Data.Geometry.Polygon
import Data.Geometry.Properties
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.PlanarGraph.Dart (allDarts,isPositive)
import qualified Data.PlaneGraph as PG
import Data.PlaneGraph( PlaneGraph, PlanarGraph, dual
, Dart, VertexId(..), FaceId(..), twin
, World(..)
, VertexId', FaceId'
, VertexData, location, vData
, HasDataOf(..)
)
import qualified Data.Sequence as Seq
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import GHC.Generics (Generic)
type Component s r = PlaneGraph (Wrap s)
(VertexId' s) (Dart s) (FaceId' s)
r
data PlanarSubdivision s v e f r =
PlanarSubdivision { _components :: V.Vector (Component s r)
, _rawVertexData :: V.Vector (Raw s (VertexId' (Wrap s)) v)
, _rawDartData :: V.Vector (Raw s (Dart (Wrap s)) e)
, _rawFaceData :: V.Vector (RawFace s f)
} deriving (Show,Eq,Functor,Generic)
makeLenses ''PlanarSubdivision
type instance NumType (PlanarSubdivision s v e f r) = r
type instance Dimension (PlanarSubdivision s v e f r) = 2
instance IsBoxable (PlanarSubdivision s v e f r) where
boundingBox = boundingBoxList' . V.toList . _components
component :: ComponentId s -> Lens' (PlanarSubdivision s v e f r)
(Component s r)
component ci = components.singular (ix $ unCI ci)
fromPlaneGraph :: forall s v e f r. (Ord r, Fractional r)
=> PlaneGraph s v e f r -> PlanarSubdivision s v e f r
fromPlaneGraph g = fromPlaneGraph' g (PG.outerFaceDart g)
fromPlaneGraph' :: forall s v e f r. PlaneGraph s v e f r -> Dart s
-> PlanarSubdivision s v e f r
fromPlaneGraph' g ofD = PlanarSubdivision (V.singleton . coerce $ g') vd ed fd
where
c = ComponentId 0
vd = V.imap (\i v -> Raw c (VertexId i) v) $ g^.PG.vertexData
ed = V.zipWith (\d dd -> Raw c d dd) allDarts'' $ g^.PG.rawDartData
fd = V.imap (\i f -> RawFace (mkFaceIdx i) (mkFaceData i f)) $ g^.PG.faceData
g' :: PlaneGraph s (VertexId' s) (Dart s) (FaceId' s) r
g' = g&PG.faceData %~ V.imap (\i _ -> mkFaceId $ flipID i)
&PG.vertexData %~ V.imap (\i _ -> VertexId i)
&PG.rawDartData .~ allDarts''
allDarts'' :: forall s'. V.Vector (Dart s')
allDarts'' = allDarts' (PG.numDarts g)
oF@(FaceId (VertexId of')) = PG.leftFace ofD g
mkFaceIdx i | i == 0 = Nothing
| otherwise = Just (c,mkFaceId . flipID $ i)
mkFaceData :: Int -> f -> FaceData (Dart s) f
mkFaceData i f | i == 0 = FaceData (Seq.singleton ofD) (g^.dataOf oF)
| i == of' = FaceData mempty (g^.dataOf (mkFaceId @s 0))
| otherwise = FaceData mempty f
mkFaceId :: forall s'. Int -> FaceId' s'
mkFaceId = FaceId . VertexId
flipID i | i == 0 = of'
| i == of' = 0
| otherwise = i
fromSimplePolygon :: (Ord r, Fractional r)
=> proxy s
-> SimplePolygon p r
-> f
-> f
-> PlanarSubdivision s p () f r
fromSimplePolygon p pg iD oD =
fromPlaneGraph (PG.fromSimplePolygon p pg iD oD)
fromConnectedSegments :: (Foldable f, Ord r, Fractional r)
=> proxy s
-> f (LineSegment 2 p r :+ e)
-> PlanarSubdivision s (NonEmpty p) e () r
fromConnectedSegments px = fromPlaneGraph . PG.fromConnectedSegments px
data PolygonFaceData = Inside | Outside deriving (Show,Read,Eq)
numComponents :: PlanarSubdivision s v e f r -> Int
numComponents = V.length . _components
numVertices :: PlanarSubdivision s v e f r -> Int
numVertices = V.length . _rawVertexData
numDarts :: PlanarSubdivision s v e f r -> Int
numDarts = V.length . _rawDartData
numEdges :: PlanarSubdivision s v e f r -> Int
numEdges = (`div` 2) . V.length . _rawDartData
numFaces :: PlanarSubdivision s v e f r -> Int
numFaces = V.length . _rawFaceData
vertices' :: PlanarSubdivision s v e f r -> V.Vector (VertexId' s)
vertices' ps = let n = numVertices ps
in V.fromList $ map VertexId [0..n-1]
vertices :: PlanarSubdivision s v e f r -> V.Vector (VertexId' s, VertexData r v)
vertices ps = (\vi -> (vi,ps^.vertexDataOf vi)) <$> vertices' ps
darts' :: PlanarSubdivision s v e f r -> V.Vector (Dart s)
darts' = allDarts' . numDarts
allDarts' :: forall s'. Int -> V.Vector (Dart s')
allDarts' n = V.fromList $ take n allDarts
edges' :: PlanarSubdivision s v e f r -> V.Vector (Dart s)
edges' = V.filter isPositive . darts'
edges :: PlanarSubdivision s v e f r -> V.Vector (Dart s, e)
edges ps = (\e -> (e,ps^.dataOf e)) <$> edges' ps
faces' :: PlanarSubdivision s v e f r -> V.Vector (FaceId' s)
faces' ps = let n = numFaces ps
in V.fromList $ map (FaceId . VertexId) [0..n-1]
faces :: PlanarSubdivision s v e f r -> V.Vector (FaceId' s, FaceData (Dart s) f)
faces ps = (\fi -> (fi,ps^.faceDataOf fi)) <$> faces' ps
internalFaces :: PlanarSubdivision s v e f r
-> V.Vector (FaceId' s, FaceData (Dart s) f)
internalFaces ps = V.tail $ faces ps
dartData :: Lens (PlanarSubdivision s v e f r) (PlanarSubdivision s v e' f r)
(V.Vector (Dart s, e)) (V.Vector (Dart s, e'))
dartData = lens getF setF
where
getF = V.imap (\i x -> (toEnum i, x^.dataVal)) . _rawDartData
setF ps ds' = ps&rawDartData %~ mkDS' ds'
mkDS' ds' ds = V.create $ do
v <- MV.new (V.length ds)
mapM_ (assignDart ds v) ds'
pure v
assignDart ds v (d,x) = let i = fromEnum d
y = ds V.! i
in MV.write v i (y&dataVal .~ x)
faceData :: Lens (PlanarSubdivision s v e f r) (PlanarSubdivision s v e f' r)
(V.Vector f) (V.Vector f')
faceData = lens getF setF
where
getF = fmap (^.faceDataVal.fData) . _rawFaceData
setF ps v' = ps&rawFaceData %~ V.zipWith (\x' x -> x&faceDataVal.fData .~ x') v'
vertexData :: Lens (PlanarSubdivision s v e f r) (PlanarSubdivision s v' e f r)
(V.Vector v) (V.Vector v')
vertexData = lens getF setF
where
getF = fmap (^.dataVal) . _rawVertexData
setF ps v' = ps&rawVertexData %~ V.zipWith (\x' x -> x&dataVal .~ x') v'
tailOf :: Dart s -> PlanarSubdivision s v e f r -> VertexId' s
tailOf d ps = let (_,d',g) = asLocalD d ps
in g^.dataOf (PG.tailOf d' g)
headOf :: Dart s -> PlanarSubdivision s v e f r -> VertexId' s
headOf d ps = let (_,d',g) = asLocalD d ps
in g^.dataOf (PG.headOf d' g)
endPoints :: Dart s -> PlanarSubdivision s v e f r
-> (VertexId' s, VertexId' s)
endPoints d ps = (tailOf d ps, headOf d ps)
incidentEdges :: VertexId' s -> PlanarSubdivision s v e f r
-> V.Vector (Dart s)
incidentEdges v ps= let (_,v',g) = asLocalV v ps
ds = PG.incidentEdges v' g
in (\d -> g^.dataOf d) <$> ds
nextIncidentEdge :: Dart s -> PlanarSubdivision s v e f r -> Dart s
nextIncidentEdge d ps = let (_,d',g) = asLocalD d ps
d'' = PG.nextIncidentEdge d' g
in g^.dataOf d''
incomingEdges :: VertexId' s -> PlanarSubdivision s v e f r -> V.Vector (Dart s)
incomingEdges v ps = orient <$> incidentEdges v ps
where
orient d = if headOf d ps == v then d else twin d
outgoingEdges :: VertexId' s -> PlanarSubdivision s v e f r -> V.Vector (Dart s)
outgoingEdges v ps = orient <$> incidentEdges v ps
where
orient d = if tailOf d ps == v then d else twin d
neighboursOf :: VertexId' s -> PlanarSubdivision s v e f r -> V.Vector (VertexId' s)
neighboursOf v ps = flip tailOf ps <$> incomingEdges v ps
leftFace :: Dart s -> PlanarSubdivision s v e f r -> FaceId' s
leftFace d ps = let (_,d',g) = asLocalD d ps
fi = PG.leftFace d' g
in g^.dataOf fi
rightFace :: Dart s -> PlanarSubdivision s v e f r -> FaceId' s
rightFace d ps = let (_,d',g) = asLocalD d ps
fi = PG.rightFace d' g
in g^.dataOf fi
outerBoundaryDarts :: FaceId' s -> PlanarSubdivision s v e f r -> V.Vector (Dart s)
outerBoundaryDarts f ps = V.concatMap single . V.fromList . NonEmpty.toList $ asLocalF f ps
where
single (_,f',g) = (\d -> g^.dataOf d) <$> PG.boundary f' g
asLocalF :: FaceId' s -> PlanarSubdivision s v e f r
-> NonEmpty (ComponentId s, FaceId' (Wrap s), Component s r)
asLocalF (FaceId (VertexId f)) ps = case ps^?!rawFaceData.ix f of
RawFace (Just (ci,f')) _ -> (ci,f',ps^.component ci) :| []
RawFace Nothing (FaceData hs _) -> toLocalF <$> NonEmpty.fromList (F.toList hs)
where
toLocalF d = let (ci,d',c) = asLocalD d ps in (ci,PG.leftFace d' c,c)
boundaryVertices :: FaceId' s -> PlanarSubdivision s v e f r
-> V.Vector (VertexId' s)
boundaryVertices f ps = (\d -> headOf d ps) <$> outerBoundaryDarts f ps
holesOf :: FaceId' s -> PlanarSubdivision s v e f r -> Seq.Seq (Dart s)
holesOf fi ps = ps^.faceDataOf fi.holes
asLocalD :: Dart s -> PlanarSubdivision s v e f r
-> (ComponentId s, Dart (Wrap s), Component s r)
asLocalD d ps = let (Raw ci d' _) = ps^?!rawDartData.ix (fromEnum d)
in (ci,d',ps^.component ci)
asLocalV :: VertexId' s -> PlanarSubdivision s v e f r
-> (ComponentId s, VertexId' (Wrap s), Component s r)
asLocalV (VertexId v) ps = let (Raw ci v' _) = ps^?!rawVertexData.ix v
in (ci,v',ps^.component ci)
vertexDataOf :: VertexId' s
-> Lens' (PlanarSubdivision s v e f r ) (VertexData r v)
vertexDataOf (VertexId vi) = lens get' set''
where
get' ps = let (Raw ci wvdi x) = ps^?!rawVertexData.ix vi
vd = ps^.component ci.PG.vertexDataOf wvdi
in vd&vData .~ x
set'' ps x = let (Raw ci wvdi _) = ps^?!rawVertexData.ix vi
in ps&rawVertexData.ix vi.dataVal .~ (x^.vData)
&component ci.PG.vertexDataOf wvdi.location .~ (x^.location)
locationOf :: VertexId' s -> Lens' (PlanarSubdivision s v e f r ) (Point 2 r)
locationOf v = vertexDataOf v.location
faceDataOf :: FaceId' s -> Lens' (PlanarSubdivision s v e f r)
(FaceData (Dart s) f)
faceDataOf fi = lens getF setF
where
(FaceId (VertexId i)) = fi
getF ps = ps^?!rawFaceData.ix i.faceDataVal
setF ps fd = ps&rawFaceData.ix i.faceDataVal .~ fd
instance HasDataOf (PlanarSubdivision s v e f r) (VertexId' s) where
type DataOf (PlanarSubdivision s v e f r) (VertexId' s) = v
dataOf v = vertexDataOf v.vData
instance HasDataOf (PlanarSubdivision s v e f r) (Dart s) where
type DataOf (PlanarSubdivision s v e f r) (Dart s) = e
dataOf d = rawDartData.singular (ix (fromEnum d)).dataVal
instance HasDataOf (PlanarSubdivision s v e f r) (FaceId' s) where
type DataOf (PlanarSubdivision s v e f r) (FaceId' s) = f
dataOf f = faceDataOf f.fData
endPointsOf :: Dart s -> Getter (PlanarSubdivision s v e f r )
(VertexData r v, VertexData r v)
endPointsOf d = to (endPointData d)
endPointData :: Dart s -> PlanarSubdivision s v e f r
-> (VertexData r v, VertexData r v)
endPointData d ps = let (u,v) = endPoints d ps
in (ps^.vertexDataOf u, ps^.vertexDataOf v)
outerFaceId :: PlanarSubdivision s v e f r -> FaceId' s
outerFaceId = const . FaceId . VertexId $ 0
edgeSegments :: PlanarSubdivision s v e f r -> V.Vector (Dart s, LineSegment 2 v r :+ e)
edgeSegments ps = (\d -> (d,edgeSegment d ps)) <$> edges' ps
edgeSegment :: Dart s -> PlanarSubdivision s v e f r -> LineSegment 2 v r :+ e
edgeSegment d ps = let (p,q) = bimap PG.vtxDataToExt PG.vtxDataToExt $ ps^.endPointsOf d
in ClosedLineSegment p q :+ ps^.dataOf d
boundary' :: Dart s -> PlanarSubdivision s v e f r -> V.Vector (Dart s)
boundary' d ps = let (_,d',g) = asLocalD d ps
in (\d'' -> g^.dataOf d'') <$> PG.boundary' d' g
rawFaceBoundary :: FaceId' s -> PlanarSubdivision s v e f r -> SimplePolygon v r :+ f
rawFaceBoundary i ps = fromPoints pts :+ (ps^.dataOf i)
where
d = V.head $ outerBoundaryDarts i ps
pts = (\d' -> PG.vtxDataToExt $ ps^.vertexDataOf (headOf d' ps))
<$> V.toList (boundary' d ps)
rawFacePolygon :: FaceId' s -> PlanarSubdivision s v e f r
-> SomePolygon v r :+ f
rawFacePolygon i ps = case F.toList $ holesOf i ps of
[] -> Left res :+ x
hs -> Right (MultiPolygon vs $ map toHole hs) :+ x
where
res@(SimplePolygon vs) :+ x = rawFaceBoundary i ps
toHole d = (rawFaceBoundary (leftFace d ps) ps)^.core
rawFacePolygons :: PlanarSubdivision s v e f r
-> V.Vector (FaceId' s, SomePolygon v r :+ f)
rawFacePolygons ps = fmap (\(i,_) -> (i,rawFacePolygon i ps)) . internalFaces $ ps
dartMapping :: PlanarSubdivision s v e f r -> V.Vector (Dart (Wrap s), Dart s)
dartMapping ps = ps^.component (ComponentId 0).PG.dartData