PlaneGraph.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.PlaneGraph( 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'

                      , headOf, tailOf, twin, endPoints

                      , incidentEdges, incomingEdges, outgoingEdges
                      , neighboursOf
                      , nextIncidentEdge, prevIncidentEdge


                      , leftFace, rightFace
                      , nextEdge, prevEdge
                      , boundary, boundary', 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           Data.ByteString (ByteString)
import qualified Data.CircularSeq as C
import           Data.Ext
import qualified Data.Foldable as F
import           Data.Function (on)
import           Data.Geometry.Interval
import           Data.Geometry.Line (cmpSlope, supportingLine)
import           Data.Geometry.LineSegment
import           Data.Geometry.Box
import           Data.Geometry.Properties
import           Data.Geometry.Point
import           Data.Geometry.Polygon
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.Semigroup
import           Data.Util
import qualified Data.Vector as V
import           GHC.Generics (Generic)
import           Debug.Trace

--------------------------------------------------------------------------------

-- | Note that the functor instance is in v
data VertexData r v = VertexData { _location :: !(Point 2 r)
                                 , _vData    :: !v
                                 } deriving (Show,Eq,Ord,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

--------------------------------------------------------------------------------

-- | Embedded, *connected*, planar graph
newtype PlaneGraph s v e f r =
    PlaneGraph { _graph :: PlanarGraph s Primal (VertexData r v) e f }
      deriving (Show,Eq,ToJSON,FromJSON)
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




--------------------------------------------------------------------------------
-- * Constructing a Plane Graph

-- | Construct a plane graph from a simple polygon. It is assumed that the
-- polygon is given in counterclockwise order.
--
-- the interior of the polygon will have faceId 0
--
-- pre: the input polygon is given in counterclockwise order
-- running time: \(O(n)\).
fromSimplePolygon                            :: proxy s
                                             -> SimplePolygon p r
                                             -> f -- ^ data inside
                                             -> f -- ^ data outside the polygon
                                             -> 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'

-- | Constructs a planar from the given vertices
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

-- | Constructs a connected plane graph
--
-- pre: The segments form a single connected component
--
-- running time: \(O(n\log n)\)
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) . sortArround (ext p) <$> sp))
           . M.assocs $ pts
    -- vertex Data
    vxData = V.fromList . map (\(p,sp) -> VertexData p (sp^._1)) $ vts
    -- The darts
    dts    = map (^._2._2) vts

--------------------------------------------------------------------------------
-- * Basic Graph information

-- | Get the number of vertices
--
-- >>> numVertices myGraph
-- 4
numVertices :: PlaneGraph s v e f r  -> Int
numVertices = PG.numVertices . _graph

-- | Get the number of Darts
--
-- >>> numDarts myGraph
-- 12
numDarts :: PlaneGraph s v e f r  -> Int
numDarts = PG.numDarts . _graph

-- | Get the number of Edges
--
-- >>> numEdges myGraph
-- 6
numEdges :: PlaneGraph s v e f r  -> Int
numEdges = PG.numEdges . _graph

-- | Get the number of faces
--
-- >>> numFaces myGraph
-- 4
numFaces :: PlaneGraph s v e f r  -> Int
numFaces = PG.numFaces . _graph

-- | Enumerate all vertices
--
-- >>> vertices' myGraph
-- [VertexId 0,VertexId 1,VertexId 2,VertexId 3]
vertices'   :: PlaneGraph s v e f r  -> V.Vector (VertexId' s)
vertices' = PG.vertices' . _graph

-- | Enumerate all vertices, together with their vertex data

-- >>> vertices myGraph
-- [(VertexId 0,()),(VertexId 1,()),(VertexId 2,()),(VertexId 3,())]
vertices   :: PlaneGraph s v e f r  -> V.Vector (VertexId' s, VertexData r v)
vertices = PG.vertices . _graph

-- | Enumerate all darts
darts' :: PlaneGraph s v e f r  -> V.Vector (Dart s)
darts' = PG.darts' . _graph

-- | Enumerate all edges. We report only the Positive darts
edges' :: PlaneGraph s v e f r  -> V.Vector (Dart s)
edges' = PG.edges' . _graph

-- | Lens to access the raw dart data, use at your own risk
rawDartData :: Lens (PlaneGraph s v e f r) (PlaneGraph s v e' f r)
                    (V.Vector e) (V.Vector e')
rawDartData = graph.PG.rawDartData

-- | lens to access the Dart Data
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

-- | Lens to access face data
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

-- | Enumerate all edges with their edge data. We report only the Positive
-- darts.
--
-- >>> mapM_ print $ edges myGraph
-- (Dart (Arc 2) +1,"c+")
-- (Dart (Arc 1) +1,"b+")
-- (Dart (Arc 0) +1,"a+")
-- (Dart (Arc 5) +1,"g+")
-- (Dart (Arc 4) +1,"e+")
-- (Dart (Arc 3) +1,"d+")
edges :: PlaneGraph s v e f r  -> V.Vector (Dart s, e)
edges = PG.edges . _graph

-- | Enumerate all faces in the plane graph
faces' :: PlaneGraph s v e f r  -> V.Vector (FaceId' s)
faces' = PG.faces' . _graph

-- | All faces with their face data.
faces :: PlaneGraph s v e f r  -> V.Vector (FaceId' s, f)
faces = PG.faces . _graph


-- | Reports the outerface and all internal faces separately.
-- running time: \(O(n)\)
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)

-- | Reports all internal faces.
-- running time: \(O(n)\)
internalFaces :: (Ord r, Fractional r)
              => PlaneGraph s v e f r -> V.Vector (FaceId' s, f)
internalFaces = snd . faces''

-- | The tail of a dart, i.e. the vertex this dart is leaving from
--
-- running time: \(O(1)\)
tailOf   :: Dart s -> PlaneGraph s v e f r  -> VertexId' s
tailOf d = PG.tailOf d . _graph

-- | The vertex this dart is heading in to
--
-- running time: \(O(1)\)
headOf   :: Dart s -> PlaneGraph s v e f r  -> VertexId' s
headOf d = PG.headOf d . _graph

-- | endPoints d g = (tailOf d g, headOf d g)
--
-- running time: \(O(1)\)
endPoints   :: Dart s -> PlaneGraph s v e f r
            -> (VertexId' s, VertexId' s)
endPoints d = PG.endPoints d . _graph

-- | All edges incident to vertex v, in counterclockwise order around v.
--
-- running time: \(O(k)\), where \(k\) is the output size
incidentEdges   :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (Dart s)
incidentEdges v = PG.incidentEdges v . _graph

-- | All incoming edges incident to vertex v, in counterclockwise order around v.
incomingEdges   :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (Dart s)
incomingEdges v = PG.incomingEdges v . _graph

-- | All outgoing edges incident to vertex v, in counterclockwise order around v.
outgoingEdges   :: VertexId' s -> PlaneGraph s v e f r  -> V.Vector (Dart s)
outgoingEdges v = PG.outgoingEdges v . _graph

-- | Gets the neighbours of a particular vertex, in counterclockwise order
-- around the vertex.
--
-- running time: \(O(k)\), where \(k\) is the output size
neighboursOf   :: VertexId' s -> PlaneGraph s v e f r
               -> V.Vector (VertexId' s)
neighboursOf v = PG.neighboursOf v . _graph

-- | Given a dart d that points into some vertex v, report the next dart in the
-- cyclic order around v.
--
-- running time: \(O(1)\)
nextIncidentEdge   :: Dart s -> PlaneGraph s v e f r -> Dart s
nextIncidentEdge d = PG.nextIncidentEdge d . _graph

-- | Given a dart d that points into some vertex v, report the next dart in the
-- cyclic order around v.
--
-- running time: \(O(1)\)
prevIncidentEdge   :: Dart s -> PlaneGraph s v e f r -> Dart s
prevIncidentEdge d = PG.prevIncidentEdge d . _graph


-- | The face to the left of the dart
--
-- >>> leftFace (dart 1 "+1") myGraph
-- FaceId 1
-- >>> leftFace (dart 1 "-1") myGraph
-- FaceId 2
-- >>> leftFace (dart 2 "+1") myGraph
-- FaceId 2
-- >>> leftFace (dart 0 "+1") myGraph
-- FaceId 0
--
-- running time: \(O(1)\).
leftFace   :: Dart s -> PlaneGraph s v e f r  -> FaceId' s
leftFace d = PG.leftFace d . _graph

-- | The face to the right of the dart
--
-- >>> rightFace (dart 1 "+1") myGraph
-- FaceId 2
-- >>> rightFace (dart 1 "-1") myGraph
-- FaceId 1
-- >>> rightFace (dart 2 "+1") myGraph
-- FaceId 1
-- >>> rightFace (dart 0 "+1") myGraph
-- FaceId 1
--
-- running time: \(O(1)\).
rightFace   :: Dart s -> PlaneGraph s v e f r  -> FaceId' s
rightFace d = PG.rightFace d . _graph


-- | Get the next edge along the face
--
--
-- running time: \(O(1)\).
nextEdge   :: Dart s -> PlaneGraph s v e f r -> Dart s
nextEdge d = PG.nextEdge d . _graph

-- | Get the previous edge along the face
--
--
-- running time: \(O(1)\).
prevEdge   :: Dart s -> PlaneGraph s v e f r -> Dart s
prevEdge d = PG.prevEdge d . _graph


-- | The darts bounding this face, for internal faces in clockwise order, for
-- the outer face in counter clockwise order.
--
--
-- running time: \(O(k)\), where \(k\) is the output size.
boundary   :: FaceId' s -> PlaneGraph s v e f r  -> V.Vector (Dart s)
boundary f = PG.boundary f . _graph

-- | Generates the darts incident to a face, starting with the given dart.
--
--
-- \(O(k)\), where \(k\) is the number of darts reported
boundary'   :: Dart s -> PlaneGraph s v e f r -> V.Vector (Dart s)
boundary' d = PG.boundary' d . _graph


-- | The vertices bounding this face, for internal faces in clockwise order, for
-- the outer face in counter clockwise order.
--
--
-- running time: \(O(k)\), where \(k\) is the output size.
boundaryVertices   :: FaceId' s -> PlaneGraph s v e f r
                   -> V.Vector (VertexId' s)
boundaryVertices f = PG.boundaryVertices f . _graph

--------------------------------------------------------------------------------
-- * Access data

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


-- | Getter for the data at the endpoints of a dart
--
-- running time: \(O(1)\)
endPointsOf   :: Dart s -> Getter (PlaneGraph s v e f r )
                                  (VertexData r v, VertexData r v)
endPointsOf d = graph.PG.endPointDataOf d

-- | Data corresponding to the endpoints of the dart
--
-- running time: \(O(1)\)
endPointData   :: Dart s -> PlaneGraph s v e f r
               ->  (VertexData r v, VertexData r v)
endPointData d = PG.endPointData d . _graph

--------------------------------------------------------------------------------

-- | gets the id of the outer face
--
-- running time: \(O(n)\)
outerFaceId    :: (Ord r, Fractional r) => PlaneGraph s v e f r -> FaceId' s
outerFaceId ps = leftFace (outerFaceDart ps) ps


-- | gets a dart incident to the outer face (in particular, that has the
-- outerface on its left)
--
-- running time: \(O(n)\)
outerFaceDart    :: (Ord r, Fractional r) => PlaneGraph s v e f r -> Dart s
outerFaceDart ps = d
  where
    (v,_)  = V.minimumBy (comparing (^._2.location.xCoord)) . vertices $ ps
    d :+ _ = V.maximumBy (cmpSlope `on` (^.extra))
           .  fmap (\d' -> d' :+ (edgeSegment d' ps)^.core.to supportingLine)
           $ incidentEdges v ps
    -- based on the approach sketched at https://cstheory.stackexchange.com/questions/27586/finding-outer-face-in-plane-graph-embedded-planar-graph
    -- basically: find the leftmost vertex, find the incident edge with the largest slope
    -- and take the face left of that edge. This is the outerface.
    -- note that this requires that the edges are straight line segments
    --



--------------------------------------------------------------------------------

-- | Reports all edges as line segments
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)

-- | Given a dart and the graph constructs the line segment representing the dart
--
-- \(O(1)\)
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

-- | The polygon describing the face
--
-- runningtime: \(O(k)\), where \(k\) is the size of the face.
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

-- | Alias for rawFace Boundary
--
-- runningtime: \(O(k)\), where \(k\) is the size of the face.
rawFacePolygon :: FaceId' s -> PlaneGraph s v e f r -> SimplePolygon v r :+ f
rawFacePolygon = rawFaceBoundary

-- | Lists all faces of the plane graph.
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


--------------------------------------------------------------------------------
-- * Reading and Writing the Plane Graph

--
-- readPlaneGraph :: (FromJSON v, FromJSON e, FromJSON f, FromJSON r)
--                           => proxy s -> ByteString
--                          -> Either String (PlaneGraph s v e f r)
-- readPlaneGraph = undefined--  parseEither


-- writePlaneGraph :: (ToJSON v, ToJSON e, ToJSON f, ToJSON r)
--                           => PlaneGraph s v e f r -> ByteString
-- writePlaneGraph = YamlP.encodePretty YamlP.defConfig

--------------------------------------------------------------------------------

-- | Labels the edges of a plane graph with their distances, as specified by
-- the distance function.
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