{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.PlaneGraph.Core(
PlaneGraph(PlaneGraph), graph
, PlanarGraph
, VertexData(VertexData), vData, location, vtxDataToExt
, fromSimplePolygon, fromConnectedSegments
, PG.fromAdjacencyLists
, numVertices, numEdges, numFaces, numDarts
, dual
, vertices', vertices
, edges', edges
, faces', faces, internalFaces, faces''
, darts', darts
, traverseVertices, traverseDarts, traverseFaces
, headOf, tailOf, twin, endPoints
, incidentEdges, incomingEdges, outgoingEdges
, neighboursOf
, nextIncidentEdge, prevIncidentEdge
, leftFace, rightFace
, nextEdge, prevEdge
, boundary, boundary', boundaryDart, boundaryVertices
, outerFaceId, outerFaceDart
, vertexDataOf, locationOf, HasDataOf(..)
, endPointsOf, endPointData
, vertexData, faceData, dartData, rawDartData
, edgeSegment, edgeSegments
, rawFacePolygon, rawFaceBoundary
, rawFacePolygons
, VertexId(..), FaceId(..), Dart, World(..), VertexId', FaceId'
, withEdgeDistances
) where
import Control.Lens hiding (holes, holesOf, (.=))
import Data.Aeson
import qualified Data.CircularSeq as C
import Data.Ext
import qualified Data.Foldable as F
import Data.Function (on)
import Data.Geometry.Box
import Data.Geometry.Interval
import Data.Geometry.Line (cmpSlope, supportingLine)
import Data.Geometry.LineSegment hiding (endPoints)
import Data.Geometry.Point
import Data.Geometry.Polygon
import Data.Geometry.Properties
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as M
import Data.Ord (comparing)
import qualified Data.PlanarGraph as PG
import Data.PlanarGraph( PlanarGraph, planarGraph, dual
, Dart(..), VertexId(..), FaceId(..), Arc(..)
, Direction(..), twin
, World(..)
, FaceId', VertexId'
, HasDataOf(..)
)
import Data.Util
import qualified Data.Vector as V
import GHC.Generics (Generic)
data VertexData r v = VertexData { _location :: !(Point 2 r)
, _vData :: !v
} deriving (Show,Eq,Ord,Generic
,Functor,Foldable,Traversable)
makeLenses ''VertexData
vtxDataToExt :: VertexData r v -> Point 2 r :+ v
vtxDataToExt (VertexData p v) = p :+ v
instance Bifunctor VertexData where
bimap f g (VertexData p v) = VertexData (fmap f p) (g v)
instance (FromJSON r, FromJSON v) => FromJSON (VertexData r v) where
parseJSON = fmap (\(l :+ d) -> VertexData l d) . parseJSON
instance (ToJSON r, ToJSON v) => ToJSON (VertexData r v) where
toJSON = toJSON . vtxDataToExt
toEncoding = toEncoding . vtxDataToExt
newtype PlaneGraph s v e f r =
PlaneGraph { _graph :: PlanarGraph s Primal (VertexData r v) e f }
deriving (Show,Eq,Generic)
makeLenses ''PlaneGraph
type instance NumType (PlaneGraph s v e f r) = r
type instance Dimension (PlaneGraph s v e f r) = 2
instance Functor (PlaneGraph s v e f) where
fmap f pg = pg&graph.PG.vertexData.traverse.location %~ fmap f
instance IsBoxable (PlaneGraph s v e f r) where
boundingBox = boundingBoxList' . F.toList . fmap (^._2.location) . vertices
fromSimplePolygon :: proxy s
-> SimplePolygon p r
-> f
-> f
-> PlaneGraph s p () f r
fromSimplePolygon p (SimplePolygon vs) iD oD = PlaneGraph g'
where
g = fromVertices p vs
fData' = V.fromList [iD, oD]
g' = g & PG.faceData .~ fData'
fromVertices :: proxy s
-> C.CSeq (Point 2 r :+ p)
-> PlanarGraph s Primal (VertexData r p) () ()
fromVertices _ vs = g&PG.vertexData .~ vData'
where
n = length vs
g = planarGraph [ [ (Dart (Arc i) Positive, ())
, (Dart (Arc $ (i+1) `mod` n) Negative, ())
]
| i <- [0..(n-1)]]
vData' = V.fromList . map (\(p :+ e) -> VertexData p e) . F.toList $ vs
fromConnectedSegments :: (Foldable f, Ord r, Num r)
=> proxy s
-> f (LineSegment 2 p r :+ e)
-> PlaneGraph s (NonEmpty.NonEmpty p) e () r
fromConnectedSegments _ ss = PlaneGraph $ planarGraph dts & PG.vertexData .~ vxData
where
pts = M.fromListWith (<>) . concatMap f . zipWith g [0..] . F.toList $ ss
f (s :+ e) = [ ( s^.start.core
, SP (sing $ s^.start.extra) [(s^.end.core) :+ h Positive e])
, ( s^.end.core
, SP (sing $ s^.end.extra) [(s^.start.core) :+ h Negative e])
]
g i (s :+ e) = s :+ (Arc i :+ e)
h d (a :+ e) = (Dart a d, e)
sing x = x NonEmpty.:| []
vts = map (\(p,sp) -> (p,map (^.extra) . sortAround (ext p) <$> sp))
. M.assocs $ pts
vxData = V.fromList . map (\(p,sp) -> VertexData p (sp^._1)) $ vts
dts = map (^._2._2) vts
numVertices :: PlaneGraph s v e f r -> Int
numVertices = PG.numVertices . _graph
numDarts :: PlaneGraph s v e f r -> Int
numDarts = PG.numDarts . _graph
numEdges :: PlaneGraph s v e f r -> Int
numEdges = PG.numEdges . _graph
numFaces :: PlaneGraph s v e f r -> Int
numFaces = PG.numFaces . _graph
vertices' :: PlaneGraph s v e f r -> V.Vector (VertexId' s)
vertices' = PG.vertices' . _graph
vertices :: PlaneGraph s v e f r -> V.Vector (VertexId' s, VertexData r v)
vertices = PG.vertices . _graph
darts' :: PlaneGraph s v e f r -> V.Vector (Dart s)
darts' = PG.darts' . _graph
darts :: PlaneGraph s v e f r -> V.Vector (Dart s, e)
darts = PG.darts . _graph
edges' :: PlaneGraph s v e f r -> V.Vector (Dart s)
edges' = PG.edges' . _graph
rawDartData :: Lens (PlaneGraph s v e f r) (PlaneGraph s v e' f r)
(V.Vector e) (V.Vector e')
rawDartData = graph.PG.rawDartData
dartData :: Lens (PlaneGraph s v e f r) (PlaneGraph s v e' f r)
(V.Vector (Dart s, e)) (V.Vector (Dart s, e'))
dartData = graph.PG.dartData
faceData :: Lens (PlaneGraph s v e f r) (PlaneGraph s v e f' r)
(V.Vector f) (V.Vector f')
faceData = graph.PG.faceData
vertexData :: Lens (PlaneGraph s v e f r) (PlaneGraph s v' e f r)
(V.Vector v) (V.Vector v')
vertexData = lens get'' set''
where
get'' pg = let v = pg^.graph.PG.vertexData in (^.vData) <$> v
set'' pg v' = pg&graph.PG.vertexData %~ V.zipWith f v'
f x (VertexData l _) = VertexData l x
edges :: PlaneGraph s v e f r -> V.Vector (Dart s, e)
edges = PG.edges . _graph
faces' :: PlaneGraph s v e f r -> V.Vector (FaceId' s)
faces' = PG.faces' . _graph
faces :: PlaneGraph s v e f r -> V.Vector (FaceId' s, f)
faces = PG.faces . _graph
faces'' :: (Ord r, Fractional r)
=> PlaneGraph s v e f r -> ((FaceId' s, f), V.Vector (FaceId' s, f))
faces'' g = let i = outerFaceId g
in ((i,g^.dataOf i), V.filter (\(j,_) -> i /= j) $ faces g)
internalFaces :: (Ord r, Fractional r)
=> PlaneGraph s v e f r -> V.Vector (FaceId' s, f)
internalFaces = snd . faces''
tailOf :: Dart s -> PlaneGraph s v e f r -> VertexId' s
tailOf d = PG.tailOf d . _graph
headOf :: Dart s -> PlaneGraph s v e f r -> VertexId' s
headOf d = PG.headOf d . _graph
endPoints :: Dart s -> PlaneGraph s v e f r
-> (VertexId' s, VertexId' s)
endPoints d = PG.endPoints d . _graph
incidentEdges :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (Dart s)
incidentEdges v = PG.incidentEdges v . _graph
incomingEdges :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (Dart s)
incomingEdges v = PG.incomingEdges v . _graph
outgoingEdges :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (Dart s)
outgoingEdges v = PG.outgoingEdges v . _graph
neighboursOf :: VertexId' s -> PlaneGraph s v e f r
-> V.Vector (VertexId' s)
neighboursOf v = PG.neighboursOf v . _graph
nextIncidentEdge :: Dart s -> PlaneGraph s v e f r -> Dart s
nextIncidentEdge d = PG.nextIncidentEdge d . _graph
prevIncidentEdge :: Dart s -> PlaneGraph s v e f r -> Dart s
prevIncidentEdge d = PG.prevIncidentEdge d . _graph
leftFace :: Dart s -> PlaneGraph s v e f r -> FaceId' s
leftFace d = PG.leftFace d . _graph
rightFace :: Dart s -> PlaneGraph s v e f r -> FaceId' s
rightFace d = PG.rightFace d . _graph
nextEdge :: Dart s -> PlaneGraph s v e f r -> Dart s
nextEdge d = PG.nextEdge d . _graph
prevEdge :: Dart s -> PlaneGraph s v e f r -> Dart s
prevEdge d = PG.prevEdge d . _graph
boundary :: FaceId' s -> PlaneGraph s v e f r -> V.Vector (Dart s)
boundary f = PG.boundary f . _graph
boundary' :: Dart s -> PlaneGraph s v e f r -> V.Vector (Dart s)
boundary' d = PG.boundary' d . _graph
boundaryDart :: FaceId' s -> PlaneGraph s v e f r -> Dart s
boundaryDart f = PG.boundaryDart f . _graph
boundaryVertices :: FaceId' s -> PlaneGraph s v e f r
-> V.Vector (VertexId' s)
boundaryVertices f = PG.boundaryVertices f . _graph
vertexDataOf :: VertexId' s -> Lens' (PlaneGraph s v e f r ) (VertexData r v)
vertexDataOf v = graph.PG.dataOf v
locationOf :: VertexId' s -> Lens' (PlaneGraph s v e f r ) (Point 2 r)
locationOf v = vertexDataOf v.location
instance HasDataOf (PlaneGraph s v e f r) (VertexId' s) where
type DataOf (PlaneGraph s v e f r) (VertexId' s) = v
dataOf v = graph.dataOf v.vData
instance HasDataOf (PlaneGraph s v e f r) (Dart s) where
type DataOf (PlaneGraph s v e f r) (Dart s) = e
dataOf d = graph.dataOf d
instance HasDataOf (PlaneGraph s v e f r) (FaceId' s) where
type DataOf (PlaneGraph s v e f r) (FaceId' s) = f
dataOf f = graph.dataOf f
traverseVertices :: Applicative m
=> (VertexId' s -> v -> m v')
-> PlaneGraph s v e f r
-> m (PlaneGraph s v' e f r)
traverseVertices f = itraverseOf (vertexData.itraversed) (\i -> f (VertexId i))
traverseDarts :: Applicative m
=> (Dart s -> e -> m e')
-> PlaneGraph s v e f r
-> m (PlaneGraph s v e' f r)
traverseDarts f = traverseOf graph (PG.traverseDarts f)
traverseFaces :: Applicative m
=> (FaceId' s -> f -> m f')
-> PlaneGraph s v e f r
-> m (PlaneGraph s v e f' r)
traverseFaces f = traverseOf graph (PG.traverseFaces f)
endPointsOf :: Dart s -> Getter (PlaneGraph s v e f r )
(VertexData r v, VertexData r v)
endPointsOf d = graph.PG.endPointDataOf d
endPointData :: Dart s -> PlaneGraph s v e f r
-> (VertexData r v, VertexData r v)
endPointData d = PG.endPointData d . _graph
outerFaceId :: (Ord r, Fractional r) => PlaneGraph s v e f r -> FaceId' s
outerFaceId ps = leftFace (outerFaceDart ps) ps
outerFaceDart :: (Ord r, Fractional r) => PlaneGraph s v e f r -> Dart s
outerFaceDart ps = d
where
(v,_) = V.minimumBy (comparing (^._2.location)) . vertices $ ps
d :+ _ = V.maximumBy (cmpSlope `on` (^.extra))
. fmap (\d' -> d' :+ (edgeSegment d' ps)^.core.to supportingLine)
$ incidentEdges v ps
edgeSegments :: PlaneGraph s v e f r -> V.Vector (Dart s, LineSegment 2 v r :+ e)
edgeSegments ps = fmap withSegment . edges $ ps
where
withSegment (d,e) = let (p,q) = bimap vtxDataToExt vtxDataToExt
$ ps^.endPointsOf d
seg = ClosedLineSegment p q
in (d, seg :+ e)
edgeSegment :: Dart s -> PlaneGraph s v e f r -> LineSegment 2 v r :+ e
edgeSegment d ps = seg :+ ps^.dataOf d
where
seg = let (p,q) = bimap vtxDataToExt vtxDataToExt $ ps^.endPointsOf d
in ClosedLineSegment p q
rawFaceBoundary :: FaceId' s -> PlaneGraph s v e f r
-> SimplePolygon v r :+ f
rawFaceBoundary i ps = pg :+ (ps^.dataOf i)
where
pg = fromPoints . F.toList . fmap (\j -> ps^.graph.dataOf j.to vtxDataToExt)
. boundaryVertices i $ ps
rawFacePolygon :: FaceId' s -> PlaneGraph s v e f r -> SimplePolygon v r :+ f
rawFacePolygon = rawFaceBoundary
rawFacePolygons :: PlaneGraph s v e f r
-> V.Vector (FaceId' s, SimplePolygon v r :+ f)
rawFacePolygons ps = fmap (\i -> (i,rawFacePolygon i ps)) . faces' $ ps
withEdgeDistances :: (Point 2 r -> Point 2 r -> a)
-> PlaneGraph s p e f r -> PlaneGraph s p (a :+ e) f r
withEdgeDistances f g = g&graph.PG.dartData %~ fmap (\(d,x) -> (d,len d :+ x))
where
len d = uncurry f . over both (^.location) $ endPointData d g