{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.PlanarGraph.IO
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Converting from/to our JSON/Yaml representation of the plane graph
--
--------------------------------------------------------------------------------
module Data.PlanarGraph.IO where

import           Control.Lens
import           Control.Monad.State.Strict
import           Data.Aeson
import           Data.Bifunctor
import           Data.Ext
import qualified Data.Foldable               as F
import           Data.Maybe                  (fromJust)
import           Data.Permutation
import           Data.PlanarGraph.AdjRep     (Face (Face), Gr (Gr), Vtx (Vtx))
import           Data.PlanarGraph.Core
import           Data.PlanarGraph.Dart
import           Data.PlanarGraph.Dual
import           Data.PlanarGraph.EdgeOracle
import           Data.Proxy
import qualified Data.Vector                 as V
import qualified Data.Vector.Mutable         as MV

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

instance (ToJSON v, ToJSON e, ToJSON f) => ToJSON (PlanarGraph s w v e f) where
  toEncoding :: PlanarGraph s w v e f -> Encoding
toEncoding = Gr (Vtx v e) (Face f) -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Gr (Vtx v e) (Face f) -> Encoding)
-> (PlanarGraph s w v e f -> Gr (Vtx v e) (Face f))
-> PlanarGraph s w v e f
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlanarGraph s w v e f -> Gr (Vtx 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)
toAdjRep
  toJSON :: PlanarGraph s w v e f -> Value
toJSON     = Gr (Vtx v e) (Face f) -> Value
forall a. ToJSON a => a -> Value
toJSON     (Gr (Vtx v e) (Face f) -> Value)
-> (PlanarGraph s w v e f -> Gr (Vtx v e) (Face f))
-> PlanarGraph s w v e f
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlanarGraph s w v e f -> Gr (Vtx 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)
toAdjRep

instance (FromJSON v, FromJSON e, FromJSON f) => FromJSON (PlanarGraph s Primal v e f) where
  parseJSON :: Value -> Parser (PlanarGraph s 'Primal v e f)
parseJSON Value
v = Proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s 'Primal 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
fromAdjRep (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) (Gr (Vtx v e) (Face f) -> PlanarGraph s 'Primal v e f)
-> Parser (Gr (Vtx v e) (Face f))
-> Parser (PlanarGraph s 'Primal v e f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Gr (Vtx v e) (Face f))
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

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


-- | Transforms the planar graph into a format that can be easily converted
-- into JSON format. 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   :: PlanarGraph s w v e f -> Gr (Vtx v e) (Face f)
toAdjRep :: PlanarGraph s w v e f -> Gr (Vtx v e) (Face f)
toAdjRep PlanarGraph s w v e f
g = [Vtx v e] -> [Face f] -> Gr (Vtx v e) (Face f)
forall v f. [v] -> [f] -> Gr v f
Gr [Vtx v e]
vs [Face f]
fs
  where
    vs :: [Vtx v e]
vs = [ Int -> [(Int, e)] -> v -> Vtx v e
forall v e. Int -> [(Int, e)] -> v -> Vtx v e
Vtx Int
ui ((VertexId s w -> (Int, e)) -> [VertexId s w] -> [(Int, e)]
forall a b. (a -> b) -> [a] -> [b]
map (VertexId s w -> VertexId s w -> (Int, e)
mkEdge VertexId s w
u) ([VertexId s w] -> [(Int, e)]) -> [VertexId s w] -> [(Int, e)]
forall a b. (a -> b) -> a -> b
$ Vector (VertexId s w) -> [VertexId s w]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Vector (VertexId s w)
us) (PlanarGraph s w v e f
gPlanarGraph s w v e f -> Getting v (PlanarGraph s w v e f) v -> v
forall s a. s -> Getting a s a -> a
^.VertexId s w
-> Lens'
     (PlanarGraph s w v e f)
     (DataOf (PlanarGraph s w v e f) (VertexId s w))
forall g i. HasDataOf g i => i -> Lens' g (DataOf g i)
dataOf VertexId s w
u)
         | (u :: VertexId s w
u@(VertexId Int
ui),Vector (VertexId s w)
us) <- PlanarGraph s w v e f -> [(VertexId s w, Vector (VertexId s w))]
forall k (s :: k) (w :: World) v e f.
PlanarGraph s w v e f -> [(VertexId s w, Vector (VertexId s w))]
toAdjacencyLists PlanarGraph s w v e f
g
         ]
    fs :: [Face f]
fs = [ (Int, Int) -> f -> Face f
forall f. (Int, Int) -> f -> Face f
Face (FaceId s w -> (Int, Int)
outerComponentEdge FaceId s w
f) f
x
         | (FaceId s w
f,f
x) <- Vector (FaceId s w, f) -> [(FaceId s w, f)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Vector (FaceId s w, f) -> [(FaceId s w, f)])
-> Vector (FaceId s w, f) -> [(FaceId s w, f)]
forall a b. (a -> b) -> a -> b
$ PlanarGraph s w v e f -> Vector (FaceId s w, f)
forall k (s :: k) (w :: World) v e f.
PlanarGraph s w v e f -> Vector (FaceId s w, f)
faces PlanarGraph s w v e f
g
         ]

    outerComponentEdge :: FaceId s w -> (Int, Int)
outerComponentEdge FaceId s w
f = (VertexId s w -> Int)
-> (VertexId s w -> Int)
-> (VertexId s w, VertexId s w)
-> (Int, Int)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (VertexId s w -> Getting Int (VertexId s w) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (VertexId s w) Int
forall k (s :: k) (w :: World). Getter (VertexId s w) Int
unVertexId) (VertexId s w -> Getting Int (VertexId s w) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (VertexId s w) Int
forall k (s :: k) (w :: World). Getter (VertexId s w) Int
unVertexId)
                         ((VertexId s w, VertexId s w) -> (Int, Int))
-> (VertexId s w, VertexId s w) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ Dart s -> PlanarGraph s w v e f -> (VertexId s w, VertexId s w)
forall k (s :: k) (w :: World) v e f.
Dart s -> PlanarGraph s w v e f -> (VertexId s w, VertexId s w)
endPoints (FaceId s w -> PlanarGraph s w v e f -> Dart s
forall k (s :: k) (w :: World) v e f.
FaceId s w -> PlanarGraph s w v e f -> Dart s
boundaryDart FaceId s w
f PlanarGraph s w v e f
g) PlanarGraph s w v e f
g

    eo :: EdgeOracle s w (Dart s)
eo = PlanarGraph s w v e f -> EdgeOracle s w (Dart s)
forall k (s :: k) (w :: World) v e f.
PlanarGraph s w v e f -> EdgeOracle s w (Dart s)
edgeOracle PlanarGraph s w v e f
g

    findData :: VertexId s w -> VertexId s w -> Maybe e
findData VertexId s w
u VertexId s w
v = (\Dart s
d -> PlanarGraph s w v e f
gPlanarGraph s w v e f -> Getting e (PlanarGraph s w v e f) e -> e
forall s a. s -> Getting a s a -> a
^.Dart s
-> Lens'
     (PlanarGraph s w v e f) (DataOf (PlanarGraph s w v e f) (Dart s))
forall g i. HasDataOf g i => i -> Lens' g (DataOf g i)
dataOf Dart s
d) (Dart s -> e) -> Maybe (Dart s) -> Maybe e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VertexId s w
-> VertexId s w -> EdgeOracle s w (Dart s) -> Maybe (Dart s)
forall k (s :: k) (w :: World).
VertexId s w
-> VertexId s w -> EdgeOracle s w (Dart s) -> Maybe (Dart s)
findDart VertexId s w
u VertexId s w
v EdgeOracle s w (Dart s)
eo
    mkEdge :: VertexId s w -> VertexId s w -> (Int, e)
mkEdge VertexId s w
u v :: VertexId s w
v@(VertexId Int
vi) = (Int
vi,Maybe e -> e
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe e -> e) -> Maybe e -> e
forall a b. (a -> b) -> a -> b
$ VertexId s w -> VertexId s w -> Maybe e
findData VertexId s w
u VertexId s w
v)


-- | Read a planar graph, given in JSON format into a planar graph. The adjacencylists
-- should be in counter clockwise order.
--
-- running time: \(O(n)\)
fromAdjRep                  :: proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s Primal v e f
fromAdjRep :: proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s 'Primal v e f
fromAdjRep proxy s
px gr :: Gr (Vtx v e) (Face f)
gr@(Gr [Vtx v e]
as [Face f]
fs) = PlanarGraph s 'Primal () () ()
gPlanarGraph s 'Primal () () ()
-> (PlanarGraph s 'Primal () () ()
    -> PlanarGraph s 'Primal v () ())
-> PlanarGraph s 'Primal v () ()
forall a b. a -> (a -> b) -> b
&(Vector () -> Identity (Vector v))
-> PlanarGraph s 'Primal () () ()
-> Identity (PlanarGraph s 'Primal v () ())
forall k (s :: k) (w :: World) v e f v'.
Lens
  (PlanarGraph s w v e f)
  (PlanarGraph s w v' e f)
  (Vector v)
  (Vector v')
vertexData ((Vector () -> Identity (Vector v))
 -> PlanarGraph s 'Primal () () ()
 -> Identity (PlanarGraph s 'Primal v () ()))
-> Vector v
-> PlanarGraph s 'Primal () () ()
-> PlanarGraph s 'Primal v () ()
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Vector (VertexId Any Any :+ v)
-> (VertexId Any Any -> Int) -> Vector v
forall i a. Vector (i :+ a) -> (i -> Int) -> Vector a
reorder Vector (VertexId Any Any :+ v)
vs' VertexId Any Any -> Int
forall k (s :: k) (w :: World). VertexId s w -> Int
_unVertexId
                               PlanarGraph s 'Primal v () ()
-> (PlanarGraph s 'Primal v () () -> PlanarGraph s 'Primal v e ())
-> PlanarGraph s 'Primal v e ()
forall a b. a -> (a -> b) -> b
&(Vector (Dart s, ()) -> Identity (Vector (Dart s, e)))
-> PlanarGraph s 'Primal v () ()
-> Identity (PlanarGraph s 'Primal v e ())
forall k (s :: k) (w :: World) v e f e'.
Lens
  (PlanarGraph s w v e f)
  (PlanarGraph s w v e' f)
  (Vector (Dart s, e))
  (Vector (Dart s, e'))
dartData   ((Vector (Dart s, ()) -> Identity (Vector (Dart s, e)))
 -> PlanarGraph s 'Primal v () ()
 -> Identity (PlanarGraph s 'Primal v e ()))
-> Vector (Dart s, e)
-> PlanarGraph s 'Primal v () ()
-> PlanarGraph s 'Primal v e ()
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Vector (Dart s, e)
ds
                               PlanarGraph s 'Primal v e ()
-> (PlanarGraph s 'Primal v e () -> PlanarGraph s 'Primal v e f)
-> PlanarGraph s 'Primal v e f
forall a b. a -> (a -> b) -> b
&(Vector () -> Identity (Vector f))
-> PlanarGraph s 'Primal v e ()
-> Identity (PlanarGraph s 'Primal v e f)
forall k (s :: k) (w :: World) v e f f'.
Lens
  (PlanarGraph s w v e f)
  (PlanarGraph s w v e f')
  (Vector f)
  (Vector f')
faceData   ((Vector () -> Identity (Vector f))
 -> PlanarGraph s 'Primal v e ()
 -> Identity (PlanarGraph s 'Primal v e f))
-> Vector f
-> PlanarGraph s 'Primal v e ()
-> PlanarGraph s 'Primal v e f
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Vector (FaceId s 'Primal :+ f)
-> (FaceId s 'Primal -> Int) -> Vector f
forall i a. Vector (i :+ a) -> (i -> Int) -> Vector a
reorder Vector (FaceId s 'Primal :+ f)
fs' (VertexId s 'Dual -> Int
forall k (s :: k) (w :: World). VertexId s w -> Int
_unVertexId(VertexId s 'Dual -> Int)
-> (FaceId s 'Primal -> VertexId s 'Dual)
-> FaceId s 'Primal
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.FaceId s 'Primal -> VertexId s 'Dual
forall k (s :: k) (w :: World). FaceId s w -> VertexId s (DualOf w)
_unFaceId)
  where
    -- build the actual graph using the adjacencies
    g :: PlanarGraph s 'Primal () () ()
g = proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s 'Primal () () ()
forall k (proxy :: k -> *) (s :: k) v e f.
proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s 'Primal () () ()
buildGraph proxy s
px Gr (Vtx v e) (Face f)
gr
    -- build an edge oracle so that we can quickly lookup the dart corresponding to a
    -- pair of vertices.
    oracle :: EdgeOracle s 'Primal (Dart s)
oracle = PlanarGraph s 'Primal () () () -> EdgeOracle s 'Primal (Dart s)
forall k (s :: k) (w :: World) v e f.
PlanarGraph s w v e f -> EdgeOracle s w (Dart s)
edgeOracle PlanarGraph s 'Primal () () ()
g
    -- function to lookup a given dart
    findEdge' :: VertexId s 'Primal -> VertexId s 'Primal -> Dart s
findEdge' VertexId s 'Primal
u VertexId s 'Primal
v = Maybe (Dart s) -> Dart s
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Dart s) -> Dart s) -> Maybe (Dart s) -> Dart s
forall a b. (a -> b) -> a -> b
$ VertexId s 'Primal
-> VertexId s 'Primal
-> EdgeOracle s 'Primal (Dart s)
-> Maybe (Dart s)
forall k (s :: k) (w :: World).
VertexId s w
-> VertexId s w -> EdgeOracle s w (Dart s) -> Maybe (Dart s)
findDart VertexId s 'Primal
u VertexId s 'Primal
v EdgeOracle s 'Primal (Dart s)
oracle
    -- faces are right of oriented darts
    findFace :: Int -> Int -> FaceId s 'Primal
findFace Int
ui Int
vi = let d :: Dart s
d = VertexId s 'Primal -> VertexId s 'Primal -> Dart s
findEdge' (Int -> VertexId s 'Primal
forall k (s :: k) (w :: World). Int -> VertexId s w
VertexId Int
ui) (Int -> VertexId s 'Primal
forall k (s :: k) (w :: World). Int -> VertexId s w
VertexId Int
vi) in Dart s -> PlanarGraph s 'Primal () () () -> FaceId s 'Primal
forall k (s :: k) (w :: World) v e f.
Dart s -> PlanarGraph s w v e f -> FaceId s w
rightFace Dart s
d PlanarGraph s 'Primal () () ()
g

    vs' :: Vector (VertexId Any Any :+ v)
vs' = [VertexId Any Any :+ v] -> Vector (VertexId Any Any :+ v)
forall a. [a] -> Vector a
V.fromList [ Int -> VertexId Any Any
forall k (s :: k) (w :: World). Int -> VertexId s w
VertexId Int
vi VertexId Any Any -> v -> VertexId Any Any :+ v
forall core extra. core -> extra -> core :+ extra
:+ v
v     | Vtx Int
vi [(Int, e)]
_ v
v <- [Vtx v e]
as ]
    fs' :: Vector (FaceId s 'Primal :+ f)
fs' = [FaceId s 'Primal :+ f] -> Vector (FaceId s 'Primal :+ f)
forall a. [a] -> Vector a
V.fromList [ Int -> Int -> FaceId s 'Primal
findFace Int
ui Int
vi FaceId s 'Primal -> f -> FaceId s 'Primal :+ f
forall core extra. core -> extra -> core :+ extra
:+ f
f | Face (Int
ui,Int
vi) f
f <- [Face f]
fs ]

    ds :: Vector (Dart s, e)
ds = [(Dart s, e)] -> Vector (Dart s, e)
forall a. [a] -> Vector a
V.fromList ([(Dart s, e)] -> Vector (Dart s, e))
-> [(Dart s, e)] -> Vector (Dart s, e)
forall a b. (a -> b) -> a -> b
$ (Vtx v e -> [(Dart s, e)]) -> [Vtx v e] -> [(Dart s, e)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Vtx Int
vi [(Int, e)]
us v
_) ->
                                   [(VertexId s 'Primal -> VertexId s 'Primal -> Dart s
findEdge' (Int -> VertexId s 'Primal
forall k (s :: k) (w :: World). Int -> VertexId s w
VertexId Int
vi) (Int -> VertexId s 'Primal
forall k (s :: k) (w :: World). Int -> VertexId s w
VertexId Int
ui), e
x) | (Int
ui,e
x) <- [(Int, e)]
us]
                                ) [Vtx v e]
as

  -- TODO: Properly handle graphs with self-loops

-- | Builds the graph from the adjacency lists (but ignores all associated data)
buildGraph              :: proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s Primal () () ()
buildGraph :: proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s 'Primal () () ()
buildGraph proxy s
_ (Gr [Vtx v e]
as' [Face f]
_) = [(VertexId s 'Primal, Vector (VertexId s 'Primal))]
-> PlanarGraph s 'Primal () () ()
forall k (s :: k) (w :: World) (h :: * -> *).
(Foldable h, Functor h) =>
[(VertexId s w, h (VertexId s w))] -> PlanarGraph s w () () ()
fromAdjacencyLists [(VertexId s 'Primal, Vector (VertexId s 'Primal))]
as
  where
    as :: [(VertexId s 'Primal, Vector (VertexId s 'Primal))]
as = [ (Int -> VertexId s 'Primal
forall k (s :: k) (w :: World). Int -> VertexId s w
VertexId Int
vi, [VertexId s 'Primal] -> Vector (VertexId s 'Primal)
forall a. [a] -> Vector a
V.fromList [Int -> VertexId s 'Primal
forall k (s :: k) (w :: World). Int -> VertexId s w
VertexId Int
ui | (Int
ui,e
_) <- [(Int, e)]
us])
         | Vtx Int
vi [(Int, e)]
us v
_ <- [Vtx v e]
as'
         ]

-- make sure we order the data values appropriately
reorder     :: V.Vector (i :+ a) -> (i -> Int) -> V.Vector a
reorder :: Vector (i :+ a) -> (i -> Int) -> Vector a
reorder Vector (i :+ a)
v i -> Int
f = (forall s. ST s (MVector s a)) -> Vector a
forall a. (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s a)) -> Vector a)
-> (forall s. ST s (MVector s a)) -> Vector a
forall a b. (a -> b) -> a -> b
$ do
                           MVector s a
v' <- Int -> ST s (MVector (PrimState (ST s)) a)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MV.new (Vector (i :+ a) -> Int
forall a. Vector a -> Int
V.length Vector (i :+ a)
v)
                           Vector (i :+ a) -> ((i :+ a) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Vector (i :+ a)
v (((i :+ a) -> ST s ()) -> ST s ())
-> ((i :+ a) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(i
i :+ a
x) ->
                             MVector (PrimState (ST s)) a -> Int -> a -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s a
MVector (PrimState (ST s)) a
v' (i -> Int
f i
i) a
x
                           MVector s a -> ST s (MVector s a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVector s a
v'

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

-- | Construct a planar graph from a adjacency matrix. For every vertex, all
-- vertices should be given in counter-clockwise order.
--
-- pre: No self-loops, and no multi-edges
--
-- running time: \(O(n)\).
fromAdjacencyLists      :: forall s w h. (Foldable h, Functor h)
                        => [(VertexId s w, h (VertexId s w))]
                        -> PlanarGraph s w () () ()
fromAdjacencyLists :: [(VertexId s w, h (VertexId s w))] -> PlanarGraph s w () () ()
fromAdjacencyLists [(VertexId s w, h (VertexId s w))]
adjM = Permutation (Dart s) -> PlanarGraph s w () () ()
forall k (s :: k) (w :: World).
Permutation (Dart s) -> PlanarGraph s w () () ()
planarGraph' (Permutation (Dart s) -> PlanarGraph s w () () ())
-> ([[Dart s]] -> Permutation (Dart s))
-> [[Dart s]]
-> PlanarGraph s w () () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[Dart s]] -> Permutation (Dart s)
forall a. Enum a => Int -> [[a]] -> Permutation a
toCycleRep Int
n ([[Dart s]] -> PlanarGraph s w () () ())
-> [[Dart s]] -> PlanarGraph s w () () ()
forall a b. (a -> b) -> a -> b
$ [[Dart s]]
perm
  where
    n :: Int
n    = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> ([[Dart s]] -> [Int]) -> [[Dart s]] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Dart s] -> Int) -> [[Dart s]] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Dart s] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Dart s]] -> Int) -> [[Dart s]] -> Int
forall a b. (a -> b) -> a -> b
$ [[Dart s]]
perm
    perm :: [[Dart s]]
perm = ((VertexId s w, [VertexId s w]) -> [Dart s])
-> [(VertexId s w, [VertexId s w])] -> [[Dart s]]
forall a b. (a -> b) -> [a] -> [b]
map (VertexId s w, [VertexId s w]) -> [Dart s]
toOrbit [(VertexId s w, [VertexId s w])]
adjM'

    adjM' :: [(VertexId s w, [VertexId s w])]
adjM' = ((VertexId s w, h (VertexId s w))
 -> (VertexId s w, [VertexId s w]))
-> [(VertexId s w, h (VertexId s w))]
-> [(VertexId s w, [VertexId s w])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((h (VertexId s w) -> [VertexId s w])
-> (VertexId s w, h (VertexId s w))
-> (VertexId s w, [VertexId s w])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second h (VertexId s w) -> [VertexId s w]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList) [(VertexId s w, h (VertexId s w))]
adjM

    -- -- | Assign Arcs
    -- adjM' = (^._1) . foldr assignArcs (SP [] 0) $ adjM

    -- Build an edgeOracle, so that we can query the arcId assigned to
    -- an edge in O(1) time.
    oracle :: EdgeOracle s w Int
    oracle :: EdgeOracle s w Int
oracle = ((Int :+ ()) -> Int)
-> EdgeOracle s w (Int :+ ()) -> EdgeOracle s w Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int :+ ()) -> Getting Int (Int :+ ()) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (Int :+ ()) Int
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) (EdgeOracle s w (Int :+ ()) -> EdgeOracle s w Int)
-> ([(VertexId s w, [VertexId s w])] -> EdgeOracle s w (Int :+ ()))
-> [(VertexId s w, [VertexId s w])]
-> EdgeOracle s w Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EdgeOracle s w () -> EdgeOracle s w (Int :+ ())
forall k (s :: k) (w :: World) e.
EdgeOracle s w e -> EdgeOracle s w (Int :+ e)
assignArcs (EdgeOracle s w () -> EdgeOracle s w (Int :+ ()))
-> ([(VertexId s w, [VertexId s w])] -> EdgeOracle s w ())
-> [(VertexId s w, [VertexId s w])]
-> EdgeOracle s w (Int :+ ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(VertexId s w, [VertexId s w :+ ()])] -> EdgeOracle s w ()
forall k (f :: * -> *) (s :: k) (w :: World) e.
Foldable f =>
[(VertexId s w, f (VertexId s w :+ e))] -> EdgeOracle s w e
buildEdgeOracle
           ([(VertexId s w, [VertexId s w :+ ()])] -> EdgeOracle s w ())
-> ([(VertexId s w, [VertexId s w])]
    -> [(VertexId s w, [VertexId s w :+ ()])])
-> [(VertexId s w, [VertexId s w])]
-> EdgeOracle s w ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((VertexId s w, [VertexId s w])
 -> (VertexId s w, [VertexId s w :+ ()]))
-> [(VertexId s w, [VertexId s w])]
-> [(VertexId s w, [VertexId s w :+ ()])]
forall a b. (a -> b) -> [a] -> [b]
map (([VertexId s w] -> [VertexId s w :+ ()])
-> (VertexId s w, [VertexId s w])
-> (VertexId s w, [VertexId s w :+ ()])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (([VertexId s w] -> [VertexId s w :+ ()])
 -> (VertexId s w, [VertexId s w])
 -> (VertexId s w, [VertexId s w :+ ()]))
-> ([VertexId s w] -> [VertexId s w :+ ()])
-> (VertexId s w, [VertexId s w])
-> (VertexId s w, [VertexId s w :+ ()])
forall a b. (a -> b) -> a -> b
$ (VertexId s w -> VertexId s w :+ ())
-> [VertexId s w] -> [VertexId s w :+ ()]
forall a b. (a -> b) -> [a] -> [b]
map VertexId s w -> VertexId s w :+ ()
forall a. a -> a :+ ()
ext)  ([(VertexId s w, [VertexId s w])] -> EdgeOracle s w Int)
-> [(VertexId s w, [VertexId s w])] -> EdgeOracle s w Int
forall a b. (a -> b) -> a -> b
$ [(VertexId s w, [VertexId s w])]
adjM'

    toOrbit :: (VertexId s w, [VertexId s w]) -> [Dart s]
toOrbit (VertexId s w
u,[VertexId s w]
adjU) = (VertexId s w -> [Dart s]) -> [VertexId s w] -> [Dart s]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (VertexId s w -> VertexId s w -> [Dart s]
toDart VertexId s w
u) [VertexId s w]
adjU

    -- if u = v we have a self-loop, so we add both a positive and a negative dart
    toDart :: VertexId s w -> VertexId s w -> [Dart s]
toDart VertexId s w
u VertexId s w
v = let Just Int
a = VertexId s w -> VertexId s w -> EdgeOracle s w Int -> Maybe Int
forall k (s :: k) (w :: World) a.
VertexId s w -> VertexId s w -> EdgeOracle s w a -> Maybe a
findEdge VertexId s w
u VertexId s w
v EdgeOracle s w Int
oracle
                 in case VertexId s w
u VertexId s w -> VertexId s w -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` VertexId s w
v of
                      Ordering
LT -> [Arc s -> Direction -> Dart s
forall k (s :: k). Arc s -> Direction -> Dart s
Dart (Int -> Arc s
forall k (s :: k). Int -> Arc s
Arc Int
a) Direction
Positive]
                      Ordering
EQ -> [Arc s -> Direction -> Dart s
forall k (s :: k). Arc s -> Direction -> Dart s
Dart (Int -> Arc s
forall k (s :: k). Int -> Arc s
Arc Int
a) Direction
Positive, Arc s -> Direction -> Dart s
forall k (s :: k). Arc s -> Direction -> Dart s
Dart (Int -> Arc s
forall k (s :: k). Int -> Arc s
Arc Int
a) Direction
Negative]
                      Ordering
GT -> [Arc s -> Direction -> Dart s
forall k (s :: k). Arc s -> Direction -> Dart s
Dart (Int -> Arc s
forall k (s :: k). Int -> Arc s
Arc Int
a) Direction
Negative]


assignArcs   :: EdgeOracle s w e -> EdgeOracle s w (Int :+ e)
assignArcs :: EdgeOracle s w e -> EdgeOracle s w (Int :+ e)
assignArcs EdgeOracle s w e
o = State Int (EdgeOracle s w (Int :+ e))
-> Int -> EdgeOracle s w (Int :+ e)
forall s a. State s a -> s -> a
evalState ((e -> StateT Int Identity (Int :+ e))
-> EdgeOracle s w e -> State Int (EdgeOracle s w (Int :+ e))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse e -> StateT Int Identity (Int :+ e)
forall e. e -> State Int (Int :+ e)
f EdgeOracle s w e
o) Int
0
  where
    f   :: e -> State Int (Int :+ e)
    f :: e -> State Int (Int :+ e)
f e
e = do Int
i <- StateT Int Identity Int
forall s (m :: * -> *). MonadState s m => m s
get ; Int -> StateT Int Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ; (Int :+ e) -> State Int (Int :+ e)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i Int -> e -> Int :+ e
forall core extra. core -> extra -> core :+ extra
:+ e
e)