{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
-- | This graph implementation is a directed (multi-)graph that only tracks
-- successors.  This encoding is very compact.  It is a multi-graph because it
-- allows parallel edges between vertices.  If you require only simple graphs,
-- careful edge insertion is required (or another graph type might be more
-- appropriate).
--
-- Limitations:
--
--  * Removing nodes and edges is not currently possible.
--
--  * Predecessors are not accessible
--
--  * Edge existence tests are /linear/ in the number of edges for
--    the source node.
module Data.Graph.Haggle.Digraph (
  MDigraph,
  Digraph,
  newMDigraph,
  newSizedMDigraph
  ) where

import qualified Control.DeepSeq as DS
import Control.Monad ( when )
import qualified Control.Monad.Primitive as P
import qualified Control.Monad.Ref as R
import qualified Data.Vector.Unboxed.Mutable as MUV
import qualified Data.Vector.Unboxed as UV

import Data.Graph.Haggle.Classes
import Data.Graph.Haggle.Internal.Basic

-- | This is a compact (mutable) directed graph.
data MDigraph m = -- See Note [Graph Representation]
  MDigraph { MDigraph m -> Ref m Int
graphVertexCount :: R.Ref m Int
           , MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeRoots :: R.Ref m (MUV.MVector (P.PrimState m) Int)
           , MDigraph m -> Ref m Int
graphEdgeCount :: R.Ref m Int
           , MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeTarget :: R.Ref m (MUV.MVector (P.PrimState m) Int)
           , MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeNext :: R.Ref m (MUV.MVector (P.PrimState m) Int)
           }

data Digraph =
  Digraph { Digraph -> Vector Int
edgeRoots :: !(UV.Vector Int)
          , Digraph -> Vector Int
edgeTargets :: !(UV.Vector Int)
          , Digraph -> Vector Int
edgeNexts :: !(UV.Vector Int)
          }

-- | The 'Digraph' is always in normal form, as the vectors are all unboxed
instance DS.NFData Digraph where
  rnf :: Digraph -> ()
rnf !Digraph
_g = ()

defaultSize :: Int
defaultSize :: Int
defaultSize = Int
128

-- | Create a new empty mutable graph with a small amount of storage
-- reserved for vertices and edges.
newMDigraph :: (P.PrimMonad m, R.MonadRef m) => m (MDigraph m)
newMDigraph :: m (MDigraph m)
newMDigraph = Int -> Int -> m (MDigraph m)
forall (m :: * -> *).
(PrimMonad m, MonadRef m) =>
Int -> Int -> m (MDigraph m)
newSizedMDigraph Int
defaultSize Int
defaultSize

-- | Create a new empty graph with storage reserved for @szVerts@ vertices
-- and @szEdges@ edges.
--
-- > g <- newSizedMDigraph szVerts szEdges
newSizedMDigraph :: (P.PrimMonad m, R.MonadRef m) => Int -> Int -> m (MDigraph m)
newSizedMDigraph :: Int -> Int -> m (MDigraph m)
newSizedMDigraph Int
szNodes Int
szEdges = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
szNodes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
szEdges Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Negative size (newSized)"
  Ref m Int
nn <- Int -> m (Ref m Int)
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
R.newRef Int
0
  Ref m Int
en <- Int -> m (Ref m Int)
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
R.newRef Int
0
  MVector (PrimState m) Int
nVec <- Int -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> m (MVector (PrimState m) a)
MUV.new Int
szNodes
  Ref m (MVector (PrimState m) Int)
nVecRef <- MVector (PrimState m) Int -> m (Ref m (MVector (PrimState m) Int))
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
R.newRef MVector (PrimState m) Int
nVec
  MVector (PrimState m) Int
eTarget <- Int -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> m (MVector (PrimState m) a)
MUV.new Int
szEdges
  Ref m (MVector (PrimState m) Int)
eTargetRef <- MVector (PrimState m) Int -> m (Ref m (MVector (PrimState m) Int))
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
R.newRef MVector (PrimState m) Int
eTarget
  MVector (PrimState m) Int
eNext <- Int -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> m (MVector (PrimState m) a)
MUV.new Int
szEdges
  Ref m (MVector (PrimState m) Int)
eNextRef <- MVector (PrimState m) Int -> m (Ref m (MVector (PrimState m) Int))
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
R.newRef MVector (PrimState m) Int
eNext
  MDigraph m -> m (MDigraph m)
forall (m :: * -> *) a. Monad m => a -> m a
return (MDigraph m -> m (MDigraph m)) -> MDigraph m -> m (MDigraph m)
forall a b. (a -> b) -> a -> b
$! MDigraph :: forall (m :: * -> *).
Ref m Int
-> Ref m (MVector (PrimState m) Int)
-> Ref m Int
-> Ref m (MVector (PrimState m) Int)
-> Ref m (MVector (PrimState m) Int)
-> MDigraph m
MDigraph { graphVertexCount :: Ref m Int
graphVertexCount = Ref m Int
nn
                   , graphEdgeRoots :: Ref m (MVector (PrimState m) Int)
graphEdgeRoots = Ref m (MVector (PrimState m) Int)
nVecRef
                   , graphEdgeCount :: Ref m Int
graphEdgeCount = Ref m Int
en
                   , graphEdgeTarget :: Ref m (MVector (PrimState m) Int)
graphEdgeTarget = Ref m (MVector (PrimState m) Int)
eTargetRef
                   , graphEdgeNext :: Ref m (MVector (PrimState m) Int)
graphEdgeNext = Ref m (MVector (PrimState m) Int)
eNextRef
                   }



instance MGraph MDigraph where
  type ImmutableGraph MDigraph = Digraph
  getVertices :: MDigraph m -> m [Vertex]
getVertices MDigraph m
g = do
    Int
nVerts <- Ref m Int -> m Int
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphVertexCount MDigraph m
g)
    [Vertex] -> m [Vertex]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int -> Vertex
V Int
v | Int
v <- [Int
0..Int
nVertsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]

  getOutEdges :: MDigraph m -> Vertex -> m [Edge]
getOutEdges MDigraph m
g (V Int
src) = do
    Int
nVerts <- Ref m Int -> m Int
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphVertexCount MDigraph m
g)
    case Int
src Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
nVerts of
      Bool
True -> [Edge] -> m [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Bool
False -> do
        MVector (PrimState m) Int
roots <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeRoots MDigraph m
g)
        Int
lstRoot <- MVector (PrimState m) Int -> Int -> m Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MUV.unsafeRead MVector (PrimState m) Int
roots Int
src
        MDigraph m -> Int -> Int -> m [Edge]
forall (m :: * -> *).
(PrimMonad m, MonadRef m) =>
MDigraph m -> Int -> Int -> m [Edge]
findEdges MDigraph m
g Int
src Int
lstRoot

  countVertices :: MDigraph m -> m Int
countVertices = Ref m Int -> m Int
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (Ref m Int -> m Int)
-> (MDigraph m -> Ref m Int) -> MDigraph m -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphVertexCount
  countEdges :: MDigraph m -> m Int
countEdges = Ref m Int -> m Int
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (Ref m Int -> m Int)
-> (MDigraph m -> Ref m Int) -> MDigraph m -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphEdgeCount

  getSuccessors :: MDigraph m -> Vertex -> m [Vertex]
getSuccessors MDigraph m
g Vertex
src = do
    [Edge]
es <- MDigraph m -> Vertex -> m [Edge]
forall (g :: (* -> *) -> *) (m :: * -> *).
(MGraph g, PrimMonad m, MonadRef m) =>
g m -> Vertex -> m [Edge]
getOutEdges MDigraph m
g Vertex
src
    [Vertex] -> m [Vertex]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Vertex] -> m [Vertex]) -> [Vertex] -> m [Vertex]
forall a b. (a -> b) -> a -> b
$ (Edge -> Vertex) -> [Edge] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Edge -> Vertex
edgeDest [Edge]
es

  freeze :: MDigraph m -> m (ImmutableGraph MDigraph)
freeze MDigraph m
g = do
    Int
nVerts <- Ref m Int -> m Int
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphVertexCount MDigraph m
g)
    Int
nEdges <- Ref m Int -> m Int
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphEdgeCount MDigraph m
g)
    MVector (PrimState m) Int
roots <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeRoots MDigraph m
g)
    MVector (PrimState m) Int
targets <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeTarget MDigraph m
g)
    MVector (PrimState m) Int
nexts <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeNext MDigraph m
g)
    Vector Int
roots' <- MVector (PrimState m) Int -> m (Vector Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
UV.freeze (Int -> MVector (PrimState m) Int -> MVector (PrimState m) Int
forall a s. Unbox a => Int -> MVector s a -> MVector s a
MUV.take Int
nVerts MVector (PrimState m) Int
roots)
    Vector Int
targets' <- MVector (PrimState m) Int -> m (Vector Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
UV.freeze (Int -> MVector (PrimState m) Int -> MVector (PrimState m) Int
forall a s. Unbox a => Int -> MVector s a -> MVector s a
MUV.take Int
nEdges MVector (PrimState m) Int
targets)
    Vector Int
nexts' <- MVector (PrimState m) Int -> m (Vector Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
UV.freeze (Int -> MVector (PrimState m) Int -> MVector (PrimState m) Int
forall a s. Unbox a => Int -> MVector s a -> MVector s a
MUV.take Int
nEdges MVector (PrimState m) Int
nexts)
    Digraph -> m Digraph
forall (m :: * -> *) a. Monad m => a -> m a
return (Digraph -> m Digraph) -> Digraph -> m Digraph
forall a b. (a -> b) -> a -> b
$! Digraph :: Vector Int -> Vector Int -> Vector Int -> Digraph
Digraph { edgeRoots :: Vector Int
edgeRoots = Vector Int
roots'
                    , edgeTargets :: Vector Int
edgeTargets = Vector Int
targets'
                    , edgeNexts :: Vector Int
edgeNexts = Vector Int
nexts'
                    }

instance MAddVertex MDigraph where
  addVertex :: MDigraph m -> m Vertex
addVertex MDigraph m
g = do
    MDigraph m -> m ()
forall (m :: * -> *).
(PrimMonad m, MonadRef m) =>
MDigraph m -> m ()
ensureNodeSpace MDigraph m
g
    Int
vid <- Ref m Int -> m Int
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef Ref m Int
r
    Ref m Int -> (Int -> Int) -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> (a -> a) -> m ()
R.modifyRef' Ref m Int
r (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    MVector (PrimState m) Int
vec <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeRoots MDigraph m
g)
    MVector (PrimState m) Int -> Int -> Int -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MUV.unsafeWrite MVector (PrimState m) Int
vec Int
vid (-Int
1)
    Vertex -> m Vertex
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Vertex
V Int
vid)
    where
      r :: Ref m Int
r = MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphVertexCount MDigraph m
g

instance MAddEdge MDigraph where
  addEdge :: MDigraph m -> Vertex -> Vertex -> m (Maybe Edge)
addEdge MDigraph m
g (V Int
src) (V Int
dst) = do
    Int
nVerts <- Ref m Int -> m Int
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphVertexCount MDigraph m
g)
    case Int
src Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
nVerts Bool -> Bool -> Bool
|| Int
dst Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
nVerts of
      Bool
True -> Maybe Edge -> m (Maybe Edge)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Edge
forall a. Maybe a
Nothing
      Bool
False -> do
        MDigraph m -> m ()
forall (m :: * -> *).
(PrimMonad m, MonadRef m) =>
MDigraph m -> m ()
ensureEdgeSpace MDigraph m
g
        Int
eid <- Ref m Int -> m Int
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphEdgeCount MDigraph m
g)
        Ref m Int -> (Int -> Int) -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> (a -> a) -> m ()
R.modifyRef' (MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphEdgeCount MDigraph m
g) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        MVector (PrimState m) Int
rootVec <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeRoots MDigraph m
g)
        -- The current list of edges for src
        Int
curListHead <- MVector (PrimState m) Int -> Int -> m Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MUV.unsafeRead MVector (PrimState m) Int
rootVec Int
src

        -- Now create the new edge
        MVector (PrimState m) Int
nextVec <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeNext MDigraph m
g)
        MVector (PrimState m) Int
targetVec <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeTarget MDigraph m
g)
        MVector (PrimState m) Int -> Int -> Int -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MUV.unsafeWrite MVector (PrimState m) Int
nextVec Int
eid Int
curListHead
        MVector (PrimState m) Int -> Int -> Int -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MUV.unsafeWrite MVector (PrimState m) Int
targetVec Int
eid Int
dst

        -- The list now starts at our new edge
        MVector (PrimState m) Int -> Int -> Int -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
MUV.unsafeWrite MVector (PrimState m) Int
rootVec Int
src Int
eid
        Maybe Edge -> m (Maybe Edge)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Edge -> m (Maybe Edge)) -> Maybe Edge -> m (Maybe Edge)
forall a b. (a -> b) -> a -> b
$ Edge -> Maybe Edge
forall a. a -> Maybe a
Just (Int -> Int -> Int -> Edge
E Int
eid Int
src Int
dst)

instance Thawable Digraph where
  type MutableGraph Digraph = MDigraph
  thaw :: Digraph -> m (MutableGraph Digraph m)
thaw Digraph
g = do
    Ref m Int
vc <- Int -> m (Ref m Int)
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
R.newRef (Vector Int -> Int
forall a. Unbox a => Vector a -> Int
UV.length (Digraph -> Vector Int
edgeRoots Digraph
g))
    Ref m Int
ec <- Int -> m (Ref m Int)
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
R.newRef (Vector Int -> Int
forall a. Unbox a => Vector a -> Int
UV.length (Digraph -> Vector Int
edgeTargets Digraph
g))
    MVector (PrimState m) Int
rvec <- Vector Int -> m (MVector (PrimState m) Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
UV.thaw (Digraph -> Vector Int
edgeRoots Digraph
g)
    MVector (PrimState m) Int
tvec <- Vector Int -> m (MVector (PrimState m) Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
UV.thaw (Digraph -> Vector Int
edgeTargets Digraph
g)
    MVector (PrimState m) Int
nvec <- Vector Int -> m (MVector (PrimState m) Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
UV.thaw (Digraph -> Vector Int
edgeNexts Digraph
g)
    Ref m (MVector (PrimState m) Int)
rref <- MVector (PrimState m) Int -> m (Ref m (MVector (PrimState m) Int))
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
R.newRef MVector (PrimState m) Int
rvec
    Ref m (MVector (PrimState m) Int)
tref <- MVector (PrimState m) Int -> m (Ref m (MVector (PrimState m) Int))
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
R.newRef MVector (PrimState m) Int
tvec
    Ref m (MVector (PrimState m) Int)
nref <- MVector (PrimState m) Int -> m (Ref m (MVector (PrimState m) Int))
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
R.newRef MVector (PrimState m) Int
nvec
    MDigraph m -> m (MDigraph m)
forall (m :: * -> *) a. Monad m => a -> m a
return MDigraph :: forall (m :: * -> *).
Ref m Int
-> Ref m (MVector (PrimState m) Int)
-> Ref m Int
-> Ref m (MVector (PrimState m) Int)
-> Ref m (MVector (PrimState m) Int)
-> MDigraph m
MDigraph { graphVertexCount :: Ref m Int
graphVertexCount = Ref m Int
vc
                    , graphEdgeCount :: Ref m Int
graphEdgeCount = Ref m Int
ec
                    , graphEdgeRoots :: Ref m (MVector (PrimState m) Int)
graphEdgeRoots = Ref m (MVector (PrimState m) Int)
rref
                    , graphEdgeTarget :: Ref m (MVector (PrimState m) Int)
graphEdgeTarget = Ref m (MVector (PrimState m) Int)
tref
                    , graphEdgeNext :: Ref m (MVector (PrimState m) Int)
graphEdgeNext = Ref m (MVector (PrimState m) Int)
nref
                    }


instance Graph Digraph where
  vertices :: Digraph -> [Vertex]
vertices Digraph
g = (Int -> Vertex) -> [Int] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Vertex
V [Int
0 .. Vector Int -> Int
forall a. Unbox a => Vector a -> Int
UV.length (Digraph -> Vector Int
edgeRoots Digraph
g) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  edges :: Digraph -> [Edge]
edges Digraph
g = (Vertex -> [Edge]) -> [Vertex] -> [Edge]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Digraph -> Vertex -> [Edge]
forall g. Graph g => g -> Vertex -> [Edge]
outEdges Digraph
g) (Digraph -> [Vertex]
forall g. Graph g => g -> [Vertex]
vertices Digraph
g)
  successors :: Digraph -> Vertex -> [Vertex]
successors Digraph
g (V Int
v)
    | Digraph -> Int -> Bool
outOfRange Digraph
g Int
v = []
    | Bool
otherwise =
      let root :: Int
root = Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
UV.unsafeIndex (Digraph -> Vector Int
edgeRoots Digraph
g) Int
v
      in Digraph -> Int -> [Vertex]
pureSuccessors Digraph
g Int
root
  outEdges :: Digraph -> Vertex -> [Edge]
outEdges Digraph
g (V Int
v)
    | Digraph -> Int -> Bool
outOfRange Digraph
g Int
v = []
    | Bool
otherwise =
      let root :: Int
root = Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
UV.unsafeIndex (Digraph -> Vector Int
edgeRoots Digraph
g) Int
v
      in Digraph -> Int -> Int -> [Edge]
pureEdges Digraph
g Int
v Int
root
  maxVertexId :: Digraph -> Int
maxVertexId Digraph
g = Vector Int -> Int
forall a. Unbox a => Vector a -> Int
UV.length (Digraph -> Vector Int
edgeRoots Digraph
g) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  isEmpty :: Digraph -> Bool
isEmpty = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0) (Int -> Bool) -> (Digraph -> Int) -> Digraph -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Int -> Int
forall a. Unbox a => Vector a -> Int
UV.length (Vector Int -> Int) -> (Digraph -> Vector Int) -> Digraph -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digraph -> Vector Int
edgeRoots

-- Helpers

outOfRange :: Digraph -> Int -> Bool
outOfRange :: Digraph -> Int -> Bool
outOfRange Digraph
g = (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Vector Int -> Int
forall a. Unbox a => Vector a -> Int
UV.length (Digraph -> Vector Int
edgeRoots Digraph
g))

pureEdges :: Digraph -> Int -> Int -> [Edge]
pureEdges :: Digraph -> Int -> Int -> [Edge]
pureEdges Digraph
_ Int
_ (-1) = []
pureEdges Digraph
g Int
src Int
ix = Int -> Int -> Int -> Edge
E Int
ix Int
src Int
dst Edge -> [Edge] -> [Edge]
forall a. a -> [a] -> [a]
: Digraph -> Int -> Int -> [Edge]
pureEdges Digraph
g Int
src Int
nxt
  where
    dst :: Int
dst = Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
UV.unsafeIndex (Digraph -> Vector Int
edgeTargets Digraph
g) Int
ix
    nxt :: Int
nxt = Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
UV.unsafeIndex (Digraph -> Vector Int
edgeNexts Digraph
g) Int
ix

pureSuccessors :: Digraph -> Int -> [Vertex]
pureSuccessors :: Digraph -> Int -> [Vertex]
pureSuccessors Digraph
_ (-1) = []
pureSuccessors Digraph
g Int
ix = Int -> Vertex
V Int
s Vertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
: Digraph -> Int -> [Vertex]
pureSuccessors Digraph
g Int
nxt
  where
    s :: Int
s = Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
UV.unsafeIndex (Digraph -> Vector Int
edgeTargets Digraph
g) Int
ix
    nxt :: Int
nxt = Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
UV.unsafeIndex (Digraph -> Vector Int
edgeNexts Digraph
g) Int
ix

-- | Given the root of a successor list, traverse it and
-- accumulate all edges, stopping at -1.
findEdges :: (P.PrimMonad m, R.MonadRef m) => MDigraph m -> Int -> Int -> m [Edge]
findEdges :: MDigraph m -> Int -> Int -> m [Edge]
findEdges MDigraph m
_ Int
_ (-1) = [Edge] -> m [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return []
findEdges MDigraph m
g Int
src Int
root = do
  MVector (PrimState m) Int
targets <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeTarget MDigraph m
g)
  MVector (PrimState m) Int
nexts <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeNext MDigraph m
g)
  let go :: [Edge] -> Int -> m [Edge]
go [Edge]
acc (-1) = [Edge] -> m [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return [Edge]
acc
      go [Edge]
acc Int
ix = do
        Int
tgt <- MVector (PrimState m) Int -> Int -> m Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MUV.unsafeRead MVector (PrimState m) Int
targets Int
ix
        Int
nxt <- MVector (PrimState m) Int -> Int -> m Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MUV.unsafeRead MVector (PrimState m) Int
nexts Int
ix
        [Edge] -> Int -> m [Edge]
go (Int -> Int -> Int -> Edge
E Int
ix Int
src Int
tgt Edge -> [Edge] -> [Edge]
forall a. a -> [a] -> [a]
: [Edge]
acc) Int
nxt
  [Edge] -> Int -> m [Edge]
go [] Int
root

-- | Given a graph, ensure that there is space in the vertex vector
-- for a new vertex.  If there is not, double the capacity.
ensureNodeSpace :: (P.PrimMonad m, R.MonadRef m) => MDigraph m -> m ()
ensureNodeSpace :: MDigraph m -> m ()
ensureNodeSpace MDigraph m
g = do
  MVector (PrimState m) Int
vec <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeRoots MDigraph m
g)
  let cap :: Int
cap = MVector (PrimState m) Int -> Int
forall a s. Unbox a => MVector s a -> Int
MUV.length MVector (PrimState m) Int
vec
  Int
cnt <- Ref m Int -> m Int
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphVertexCount MDigraph m
g)
  case Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
cap of
    Bool
True -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Bool
False -> do
      MVector (PrimState m) Int
vec' <- MVector (PrimState m) Int -> Int -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a)
MUV.grow MVector (PrimState m) Int
vec Int
cap
      Ref m (MVector (PrimState m) Int)
-> MVector (PrimState m) Int -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
R.writeRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeRoots MDigraph m
g) MVector (PrimState m) Int
vec'

-- | Ensure that the graph has space for another edge.  If there is not,
-- double the edge capacity.
ensureEdgeSpace :: (P.PrimMonad m, R.MonadRef m) => MDigraph m -> m ()
ensureEdgeSpace :: MDigraph m -> m ()
ensureEdgeSpace MDigraph m
g = do
  MVector (PrimState m) Int
v1 <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeTarget MDigraph m
g)
  MVector (PrimState m) Int
v2 <- Ref m (MVector (PrimState m) Int) -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeNext MDigraph m
g)
  Int
nEdges <- Ref m Int -> m Int
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
R.readRef (MDigraph m -> Ref m Int
forall (m :: * -> *). MDigraph m -> Ref m Int
graphEdgeCount MDigraph m
g)
  let cap :: Int
cap = MVector (PrimState m) Int -> Int
forall a s. Unbox a => MVector s a -> Int
MUV.length MVector (PrimState m) Int
v1
  case Int
nEdges Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
cap of
    Bool
True -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Bool
False -> do
      MVector (PrimState m) Int
v1' <- MVector (PrimState m) Int -> Int -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a)
MUV.grow MVector (PrimState m) Int
v1 Int
cap
      MVector (PrimState m) Int
v2' <- MVector (PrimState m) Int -> Int -> m (MVector (PrimState m) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a)
MUV.grow MVector (PrimState m) Int
v2 Int
cap
      Ref m (MVector (PrimState m) Int)
-> MVector (PrimState m) Int -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
R.writeRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeTarget MDigraph m
g) MVector (PrimState m) Int
v1'
      Ref m (MVector (PrimState m) Int)
-> MVector (PrimState m) Int -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
R.writeRef (MDigraph m -> Ref m (MVector (PrimState m) Int)
forall (m :: * -> *).
MDigraph m -> Ref m (MVector (PrimState m) Int)
graphEdgeNext MDigraph m
g) MVector (PrimState m) Int
v2'

{- Note [Graph Representation]

The edge roots vector is indexed by vertex id.  A -1 in the
vector indicates that there are no edges leaving the vertex.
Any other value is an index into BOTH the graphEdgeTarget and
graphEdgeNext vectors.

The graphEdgeTarget vector contains the vertex id of an edge
target.

The graphEdgeNext vector contains, at the same index, the index
of the next edge in the edge list (again into Target and Next).
A -1 indicates no more edges.

-}