{-# OPTIONS_GHC -fno-warn-orphans #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.PlaneGraph.IO
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Converting from/to Adjacency Representation of the plane graph
--
--------------------------------------------------------------------------------
module Data.PlaneGraph.IO where

import           Control.Lens
import           Control.Monad (forM_)
import           Data.Aeson
import           Data.Bifunctor
import qualified Data.ByteString as B
import           Data.Geometry.Point
import qualified Data.List as List
import qualified Data.PlanarGraph.AdjRep as PGA
import qualified Data.PlanarGraph.IO as PGIO
import           Data.PlaneGraph.Core
import           Data.PlaneGraph.AdjRep (Face,Vtx(Vtx),Gr(Gr))
import           Data.Proxy
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import           Data.Yaml (ParseException)
import           Data.Yaml.Util

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

-- $setup
-- >>> import Data.PlanarGraph.Dart
-- >>> import Data.PlanarGraph.AdjRep(Face(..))
-- >>> :{
-- let dart i s = Dart (Arc i) (read s)
--     small :: Gr (Vtx Int String Int) (Face String)
--     small = Gr [ Vtx 0 (Point2 0 0) [ (2,"0->2")
--                                     , (1,"0->1")
--                                     , (3,"0->3")
--                                     ] 0
--                , Vtx 1 (Point2 2 2) [ (0,"1->0")
--                                     , (2,"1->2")
--                                     , (3,"1->3")
--                                     ] 1
--                , Vtx 2 (Point2 2 0) [ (0,"2->0")
--                                     , (1,"2->1")
--                                     ] 2
--                , Vtx 3 (Point2 (-1) 4) [ (0,"3->0")
--                                        , (1,"3->1")
--                                        ] 3
--                ]
--                [ Face (2,1) "OuterFace"
--                , Face (0,1) "A"
--                , Face (1,0) "B"
--                ]
--     smallG = fromAdjRep (Proxy :: Proxy ()) small
-- :}
--
--
-- This represents the following graph. Note that the graph is undirected, the
-- arrows are just to indicate what the Positive direction of the darts is.
--
-- ![myGraph](docs/Data/PlaneGraph/small.png)

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

-- | Reads a plane graph from a bytestring
readPlaneGraph   :: (FromJSON v, FromJSON e, FromJSON f, FromJSON r)
                 => proxy s -> B.ByteString
                 -> Either ParseException (PlaneGraph s v e f r)
readPlaneGraph :: proxy s
-> ByteString -> Either ParseException (PlaneGraph s v e f r)
readPlaneGraph proxy s
_ = ByteString -> Either ParseException (PlaneGraph s v e f r)
forall a. FromJSON a => ByteString -> Either ParseException a
decodeYaml

-- | Writes a plane graph to a bytestring
writePlaneGraph :: (ToJSON v, ToJSON e, ToJSON f, ToJSON r)
                => PlaneGraph s v e f r -> B.ByteString
writePlaneGraph :: PlaneGraph s v e f r -> ByteString
writePlaneGraph = PlaneGraph s v e f r -> ByteString
forall a. ToJSON a => a -> ByteString
encodeYaml

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

instance (ToJSON v, ToJSON e, ToJSON f, ToJSON r) => ToJSON (PlaneGraph s v e f r) where
  toEncoding :: PlaneGraph s v e f r -> Encoding
toEncoding = Gr (Vtx v e r) (Face f) -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Gr (Vtx v e r) (Face f) -> Encoding)
-> (PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f))
-> PlaneGraph s v e f r
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
forall k (s :: k) v e f r.
PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
toAdjRep
  toJSON :: PlaneGraph s v e f r -> Value
toJSON     = Gr (Vtx v e r) (Face f) -> Value
forall a. ToJSON a => a -> Value
toJSON     (Gr (Vtx v e r) (Face f) -> Value)
-> (PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f))
-> PlaneGraph s v e f r
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
forall k (s :: k) v e f r.
PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
toAdjRep

instance (FromJSON v, FromJSON e, FromJSON f, FromJSON r)
         => FromJSON (PlaneGraph s v e f r) where
  parseJSON :: Value -> Parser (PlaneGraph s v e f r)
parseJSON Value
v = Proxy s -> Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r
forall k (proxy :: k -> *) (s :: k) v e r f.
proxy s -> Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r
fromAdjRep (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) (Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r)
-> Parser (Gr (Vtx v e r) (Face f))
-> Parser (PlaneGraph s v e f r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Gr (Vtx v e r) (Face f))
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

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

-- | Transforms the plane graph into adjacency lists. For every
-- vertex, the adjacent vertices are given in counter clockwise order.
--
-- See 'toAdjacencyLists' for notes on how we handle self-loops.
--
-- running time: \(O(n)\)
toAdjRep :: PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
toAdjRep :: PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
toAdjRep = (Vtx (VertexData r v) e -> Vtx v e r)
-> Gr (Vtx (VertexData r v) e) (Face f) -> Gr (Vtx v e r) (Face f)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\(PGA.Vtx Int
v [(Int, e)]
aj (VertexData Point 2 r
p v
x)) -> Int -> Point 2 r -> [(Int, e)] -> v -> Vtx v e r
forall v e r. Int -> Point 2 r -> [(Int, e)] -> v -> Vtx v e r
Vtx Int
v Point 2 r
p [(Int, e)]
aj v
x) (Gr (Vtx (VertexData r v) e) (Face f) -> Gr (Vtx v e r) (Face f))
-> (PlaneGraph s v e f r -> Gr (Vtx (VertexData r v) e) (Face f))
-> PlaneGraph s v e f r
-> Gr (Vtx v e r) (Face f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlanarGraph s 'Primal (VertexData r v) e f
-> Gr (Vtx (VertexData r v) e) (Face f)
forall k (s :: k) (w :: World) v e f.
PlanarGraph s w v e f -> Gr (Vtx v e) (Face f)
PGIO.toAdjRep
         (PlanarGraph s 'Primal (VertexData r v) e f
 -> Gr (Vtx (VertexData r v) e) (Face f))
-> (PlaneGraph s v e f r
    -> PlanarGraph s 'Primal (VertexData r v) e f)
-> PlaneGraph s v e f r
-> Gr (Vtx (VertexData r v) e) (Face f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Getting
  (PlanarGraph s 'Primal (VertexData r v) e f)
  (PlaneGraph s v e f r)
  (PlanarGraph s 'Primal (VertexData r v) e f)
-> PlaneGraph s v e f r
-> PlanarGraph s 'Primal (VertexData r v) e f
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (PlanarGraph s 'Primal (VertexData r v) e f)
  (PlaneGraph s v e f r)
  (PlanarGraph s 'Primal (VertexData r v) e f)
forall k (s :: k) v e f r k2 (s2 :: k2) v2 e2 f2 r2.
Iso
  (PlaneGraph s v e f r)
  (PlaneGraph s2 v2 e2 f2 r2)
  (PlanarGraph s 'Primal (VertexData r v) e f)
  (PlanarGraph s2 'Primal (VertexData r2 v2) e2 f2)
graph

-- | Given the AdjacencyList representation of a plane graph,
-- construct the plane graph representing it. All the adjacencylists
-- should be in counter clockwise order.
--
-- running time: \(O(n)\)
fromAdjRep    :: proxy s -> Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r
fromAdjRep :: proxy s -> Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r
fromAdjRep proxy s
px = PlanarGraph s 'Primal (VertexData r v) e f -> PlaneGraph s v e f r
forall k (s :: k) v e f r.
PlanarGraph s 'Primal (VertexData r v) e f -> PlaneGraph s v e f r
PlaneGraph (PlanarGraph s 'Primal (VertexData r v) e f
 -> PlaneGraph s v e f r)
-> (Gr (Vtx v e r) (Face f)
    -> PlanarGraph s 'Primal (VertexData r v) e f)
-> Gr (Vtx v e r) (Face f)
-> PlaneGraph s v e f r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy s
-> Gr (Vtx (VertexData r v) e) (Face f)
-> PlanarGraph s 'Primal (VertexData r v) e f
forall k (proxy :: k -> *) (s :: k) v e f.
proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s 'Primal v e f
PGIO.fromAdjRep proxy s
px
              (Gr (Vtx (VertexData r v) e) (Face f)
 -> PlanarGraph s 'Primal (VertexData r v) e f)
-> (Gr (Vtx v e r) (Face f)
    -> Gr (Vtx (VertexData r v) e) (Face f))
-> Gr (Vtx v e r) (Face f)
-> PlanarGraph s 'Primal (VertexData r v) e f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vtx v e r -> Vtx (VertexData r v) e)
-> Gr (Vtx v e r) (Face f) -> Gr (Vtx (VertexData r v) e) (Face f)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\(Vtx Int
v Point 2 r
p [(Int, e)]
aj v
x) -> Int -> [(Int, e)] -> VertexData r v -> Vtx (VertexData r v) e
forall v e. Int -> [(Int, e)] -> v -> Vtx v e
PGA.Vtx Int
v [(Int, e)]
aj (VertexData r v -> Vtx (VertexData r v) e)
-> VertexData r v -> Vtx (VertexData r v) e
forall a b. (a -> b) -> a -> b
$ Point 2 r -> v -> VertexData r v
forall r v. Point 2 r -> v -> VertexData r v
VertexData Point 2 r
p v
x)

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

-- | Orders the adjacencylists of a plane graph (with \(n\) vertices) (in Adj
-- repr) so that they are all counter-clockwise around the vertices.
--
-- running time: \(O(n \log n)\)
makeCCW            :: (Num r, Ord r) => Gr (Vtx v e r) f -> Gr (Vtx v e r) f
makeCCW :: Gr (Vtx v e r) f -> Gr (Vtx v e r) f
makeCCW (Gr [Vtx v e r]
vs [f]
fs) = [Vtx v e r] -> [f] -> Gr (Vtx v e r) f
forall v f. [v] -> [f] -> Gr v f
Gr ((Vtx v e r -> Vtx v e r) -> [Vtx v e r] -> [Vtx v e r]
forall a b. (a -> b) -> [a] -> [b]
map Vtx v e r -> Vtx v e r
sort' [Vtx v e r]
vs) [f]
fs
  where
    -- create an array that we can use to lookup the vertex locations in constant time.
    location' :: Vector (Point 2 r)
location' = (forall s. ST s (MVector s (Point 2 r))) -> Vector (Point 2 r)
forall a. (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s (Point 2 r))) -> Vector (Point 2 r))
-> (forall s. ST s (MVector s (Point 2 r))) -> Vector (Point 2 r)
forall a b. (a -> b) -> a -> b
$ do
                   MVector s (Point 2 r)
a <- Int -> ST s (MVector (PrimState (ST s)) (Point 2 r))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MV.new ([Vtx v e r] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Vtx v e r]
vs)
                   [Vtx v e r] -> (Vtx v e r -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Vtx v e r]
vs ((Vtx v e r -> ST s ()) -> ST s ())
-> (Vtx v e r -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Vtx Int
i Point 2 r
p [(Int, e)]
_ v
_) ->
                     MVector (PrimState (ST s)) (Point 2 r)
-> Int -> Point 2 r -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s (Point 2 r)
MVector (PrimState (ST s)) (Point 2 r)
a Int
i Point 2 r
p
                   MVector s (Point 2 r) -> ST s (MVector s (Point 2 r))
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVector s (Point 2 r)
a
    -- sort the adjacencies around every vertex v
    sort' :: Vtx v e r -> Vtx v e r
sort' (Vtx Int
v Point 2 r
p [(Int, e)]
ajs v
x) = Int -> Point 2 r -> [(Int, e)] -> v -> Vtx v e r
forall v e r. Int -> Point 2 r -> [(Int, e)] -> v -> Vtx v e r
Vtx Int
v Point 2 r
p (((Int, e) -> (Int, e) -> Ordering) -> [(Int, e)] -> [(Int, e)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (Point 2 r -> (Int, e) -> (Int, e) -> Ordering
around Point 2 r
p) [(Int, e)]
ajs) v
x
    around :: Point 2 r -> (Int, e) -> (Int, e) -> Ordering
around Point 2 r
p (Int
a,e
_) (Int
b,e
_) = Point 2 r -> Point 2 r -> Point 2 r -> Ordering
forall r.
(Num r, Ord r) =>
Point 2 r -> Point 2 r -> Point 2 r -> Ordering
ccwCmpAround Point 2 r
p (Vector (Point 2 r)
location' Vector (Point 2 r) -> Int -> Point 2 r
forall a. Vector a -> Int -> a
V.! Int
a) (Vector (Point 2 r)
location' Vector (Point 2 r) -> Int -> Point 2 r
forall a. Vector a -> Int -> a
V.! Int
b)
                           -- note: since the graph is planar, there should not be
                           -- any pairs of points for which ccwCmpAround returns EQ
                           -- hence, no need to pick a secondary comparison

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