{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
# if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE Safe #-}
# else
{-# LANGUAGE Trustworthy #-}
# endif
#endif
#include "containers.h"
module Data.Graph (
Graph
, Bounds
, Edge
, Vertex
, Table
, graphFromEdges
, graphFromEdges'
, buildG
, vertices
, edges
, outdegree
, indegree
, transposeG
, dfs
, dff
, topSort
, reverseTopSort
, components
, scc
, bcc
, reachable
, path
, SCC(..)
, stronglyConnComp
, stronglyConnCompR
, flattenSCC
, flattenSCCs
, module Data.Tree
) where
#if USE_ST_MONAD
import Control.Monad.ST
import Data.Array.ST.Safe (newArray, readArray, writeArray)
# if USE_UNBOXED_ARRAYS
import Data.Array.ST.Safe (STUArray)
# else
import Data.Array.ST.Safe (STArray)
# endif
#else
import Data.IntSet (IntSet)
import qualified Data.IntSet as Set
#endif
import Data.Tree (Tree(Node), Forest)
import Control.Applicative
#if !MIN_VERSION_base(4,8,0)
import qualified Data.Foldable as F
import Data.Traversable
#else
import Data.Foldable as F
#endif
import Control.DeepSeq (NFData(rnf))
import Data.Maybe
import Data.Array
#if USE_UNBOXED_ARRAYS
import qualified Data.Array.Unboxed as UA
import Data.Array.Unboxed ( UArray )
#else
import qualified Data.Array as UA
#endif
import qualified Data.List as L
#if MIN_VERSION_base(4,9,0)
import Data.Functor.Classes
#endif
#if (!MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup (..))
#endif
#ifdef __GLASGOW_HASKELL__
import GHC.Generics (Generic, Generic1)
import Data.Data (Data)
import Data.Typeable
#endif
default ()
data SCC vertex = AcyclicSCC vertex
| CyclicSCC [vertex]
#if __GLASGOW_HASKELL__ >= 802
deriving ( SCC vertex -> SCC vertex -> Bool
forall vertex. Eq vertex => SCC vertex -> SCC vertex -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SCC vertex -> SCC vertex -> Bool
$c/= :: forall vertex. Eq vertex => SCC vertex -> SCC vertex -> Bool
== :: SCC vertex -> SCC vertex -> Bool
$c== :: forall vertex. Eq vertex => SCC vertex -> SCC vertex -> Bool
Eq
, Vertex -> SCC vertex -> ShowS
forall vertex. Show vertex => Vertex -> SCC vertex -> ShowS
forall vertex. Show vertex => [SCC vertex] -> ShowS
forall vertex. Show vertex => SCC vertex -> String
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SCC vertex] -> ShowS
$cshowList :: forall vertex. Show vertex => [SCC vertex] -> ShowS
show :: SCC vertex -> String
$cshow :: forall vertex. Show vertex => SCC vertex -> String
showsPrec :: Vertex -> SCC vertex -> ShowS
$cshowsPrec :: forall vertex. Show vertex => Vertex -> SCC vertex -> ShowS
Show
, ReadPrec [SCC vertex]
ReadPrec (SCC vertex)
ReadS [SCC vertex]
forall vertex. Read vertex => ReadPrec [SCC vertex]
forall vertex. Read vertex => ReadPrec (SCC vertex)
forall vertex. Read vertex => Vertex -> ReadS (SCC vertex)
forall vertex. Read vertex => ReadS [SCC vertex]
forall a.
(Vertex -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SCC vertex]
$creadListPrec :: forall vertex. Read vertex => ReadPrec [SCC vertex]
readPrec :: ReadPrec (SCC vertex)
$creadPrec :: forall vertex. Read vertex => ReadPrec (SCC vertex)
readList :: ReadS [SCC vertex]
$creadList :: forall vertex. Read vertex => ReadS [SCC vertex]
readsPrec :: Vertex -> ReadS (SCC vertex)
$creadsPrec :: forall vertex. Read vertex => Vertex -> ReadS (SCC vertex)
Read
)
#else
deriving (Eq, Show, Read)
#endif
INSTANCE_TYPEABLE1(SCC)
#ifdef __GLASGOW_HASKELL__
deriving instance Data vertex => Data (SCC vertex)
deriving instance Generic1 SCC
deriving instance Generic (SCC vertex)
#endif
#if MIN_VERSION_base(4,9,0)
instance Eq1 SCC where
liftEq :: forall a b. (a -> b -> Bool) -> SCC a -> SCC b -> Bool
liftEq a -> b -> Bool
eq (AcyclicSCC a
v1) (AcyclicSCC b
v2) = a -> b -> Bool
eq a
v1 b
v2
liftEq a -> b -> Bool
eq (CyclicSCC [a]
vs1) (CyclicSCC [b]
vs2) = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq [a]
vs1 [b]
vs2
liftEq a -> b -> Bool
_ SCC a
_ SCC b
_ = Bool
False
instance Show1 SCC where
liftShowsPrec :: forall a.
(Vertex -> a -> ShowS)
-> ([a] -> ShowS) -> Vertex -> SCC a -> ShowS
liftShowsPrec Vertex -> a -> ShowS
sp [a] -> ShowS
_sl Vertex
d (AcyclicSCC a
v) = forall a. (Vertex -> a -> ShowS) -> String -> Vertex -> a -> ShowS
showsUnaryWith Vertex -> a -> ShowS
sp String
"AcyclicSCC" Vertex
d a
v
liftShowsPrec Vertex -> a -> ShowS
_sp [a] -> ShowS
sl Vertex
d (CyclicSCC [a]
vs) = forall a. (Vertex -> a -> ShowS) -> String -> Vertex -> a -> ShowS
showsUnaryWith (forall a b. a -> b -> a
const [a] -> ShowS
sl) String
"CyclicSCC" Vertex
d [a]
vs
instance Read1 SCC where
liftReadsPrec :: forall a.
(Vertex -> ReadS a) -> ReadS [a] -> Vertex -> ReadS (SCC a)
liftReadsPrec Vertex -> ReadS a
rp ReadS [a]
rl = forall a. (String -> ReadS a) -> Vertex -> ReadS a
readsData forall a b. (a -> b) -> a -> b
$
forall a t.
(Vertex -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith Vertex -> ReadS a
rp String
"AcyclicSCC" forall vertex. vertex -> SCC vertex
AcyclicSCC forall a. Semigroup a => a -> a -> a
<>
forall a t.
(Vertex -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith (forall a b. a -> b -> a
const ReadS [a]
rl) String
"CyclicSCC" forall vertex. [vertex] -> SCC vertex
CyclicSCC
#endif
instance F.Foldable SCC where
foldr :: forall a b. (a -> b -> b) -> b -> SCC a -> b
foldr a -> b -> b
c b
n (AcyclicSCC a
v) = a -> b -> b
c a
v b
n
foldr a -> b -> b
c b
n (CyclicSCC [a]
vs) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
c b
n [a]
vs
instance Traversable SCC where
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SCC a -> f (SCC b)
traverse a -> f b
f (AcyclicSCC a
vertex) = forall vertex. vertex -> SCC vertex
AcyclicSCC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
vertex
traverse a -> f b
_f (CyclicSCC []) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall vertex. [vertex] -> SCC vertex
CyclicSCC [])
traverse a -> f b
f (CyclicSCC (a
x : [a]
xs)) =
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\b
x' [b]
xs' -> forall vertex. [vertex] -> SCC vertex
CyclicSCC (b
x' forall a. a -> [a] -> [a]
: [b]
xs')) (a -> f b
f a
x) (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f [a]
xs)
instance NFData a => NFData (SCC a) where
rnf :: SCC a -> ()
rnf (AcyclicSCC a
v) = forall a. NFData a => a -> ()
rnf a
v
rnf (CyclicSCC [a]
vs) = forall a. NFData a => a -> ()
rnf [a]
vs
instance Functor SCC where
fmap :: forall a b. (a -> b) -> SCC a -> SCC b
fmap a -> b
f (AcyclicSCC a
v) = forall vertex. vertex -> SCC vertex
AcyclicSCC (a -> b
f a
v)
fmap a -> b
f (CyclicSCC [a]
vs) = forall vertex. [vertex] -> SCC vertex
CyclicSCC (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f [a]
vs)
flattenSCCs :: [SCC a] -> [a]
flattenSCCs :: forall a. [SCC a] -> [a]
flattenSCCs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. SCC a -> [a]
flattenSCC
flattenSCC :: SCC vertex -> [vertex]
flattenSCC :: forall a. SCC a -> [a]
flattenSCC (AcyclicSCC vertex
v) = [vertex
v]
flattenSCC (CyclicSCC [vertex]
vs) = [vertex]
vs
stronglyConnComp
:: Ord key
=> [(node, key, [key])]
-> [SCC node]
stronglyConnComp :: forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [(node, key, [key])]
edges0
= forall a b. (a -> b) -> [a] -> [b]
map forall {vertex} {b} {c}. SCC (vertex, b, c) -> SCC vertex
get_node (forall key node.
Ord key =>
[(node, key, [key])] -> [SCC (node, key, [key])]
stronglyConnCompR [(node, key, [key])]
edges0)
where
get_node :: SCC (vertex, b, c) -> SCC vertex
get_node (AcyclicSCC (vertex
n, b
_, c
_)) = forall vertex. vertex -> SCC vertex
AcyclicSCC vertex
n
get_node (CyclicSCC [(vertex, b, c)]
triples) = forall vertex. [vertex] -> SCC vertex
CyclicSCC [vertex
n | (vertex
n,b
_,c
_) <- [(vertex, b, c)]
triples]
stronglyConnCompR
:: Ord key
=> [(node, key, [key])]
-> [SCC (node, key, [key])]
stronglyConnCompR :: forall key node.
Ord key =>
[(node, key, [key])] -> [SCC (node, key, [key])]
stronglyConnCompR [] = []
stronglyConnCompR [(node, key, [key])]
edges0
= forall a b. (a -> b) -> [a] -> [b]
map Tree Vertex -> SCC (node, key, [key])
decode Forest Vertex
forest
where
(Graph
graph, Vertex -> (node, key, [key])
vertex_fn,key -> Maybe Vertex
_) = forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
graphFromEdges [(node, key, [key])]
edges0
forest :: Forest Vertex
forest = Graph -> Forest Vertex
scc Graph
graph
decode :: Tree Vertex -> SCC (node, key, [key])
decode (Node Vertex
v []) | Vertex -> Bool
mentions_itself Vertex
v = forall vertex. [vertex] -> SCC vertex
CyclicSCC [Vertex -> (node, key, [key])
vertex_fn Vertex
v]
| Bool
otherwise = forall vertex. vertex -> SCC vertex
AcyclicSCC (Vertex -> (node, key, [key])
vertex_fn Vertex
v)
decode Tree Vertex
other = forall vertex. [vertex] -> SCC vertex
CyclicSCC (Tree Vertex -> [(node, key, [key])] -> [(node, key, [key])]
dec Tree Vertex
other [])
where
dec :: Tree Vertex -> [(node, key, [key])] -> [(node, key, [key])]
dec (Node Vertex
v Forest Vertex
ts) [(node, key, [key])]
vs = Vertex -> (node, key, [key])
vertex_fn Vertex
v forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tree Vertex -> [(node, key, [key])] -> [(node, key, [key])]
dec [(node, key, [key])]
vs Forest Vertex
ts
mentions_itself :: Vertex -> Bool
mentions_itself Vertex
v = Vertex
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Graph
graph forall i e. Ix i => Array i e -> i -> e
! Vertex
v)
type Vertex = Int
type Table a = Array Vertex a
type Graph = Array Vertex [Vertex]
type Bounds = (Vertex, Vertex)
type Edge = (Vertex, Vertex)
#if !USE_UNBOXED_ARRAYS
type UArray i a = Array i a
#endif
vertices :: Graph -> [Vertex]
vertices :: Graph -> [Vertex]
vertices = forall i e. Ix i => Array i e -> [i]
indices
edges :: Graph -> [Edge]
edges :: Graph -> [Edge]
edges Graph
g = [ (Vertex
v, Vertex
w) | Vertex
v <- Graph -> [Vertex]
vertices Graph
g, Vertex
w <- Graph
gforall i e. Ix i => Array i e -> i -> e
!Vertex
v ]
buildG :: Bounds -> [Edge] -> Graph
buildG :: Edge -> [Edge] -> Graph
buildG Edge
bounds0 [Edge]
edges0 = forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray (forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] Edge
bounds0 [Edge]
edges0
transposeG :: Graph -> Graph
transposeG :: Graph -> Graph
transposeG Graph
g = Edge -> [Edge] -> Graph
buildG (forall i e. Array i e -> (i, i)
bounds Graph
g) (Graph -> [Edge]
reverseE Graph
g)
reverseE :: Graph -> [Edge]
reverseE :: Graph -> [Edge]
reverseE Graph
g = [ (Vertex
w, Vertex
v) | (Vertex
v, Vertex
w) <- Graph -> [Edge]
edges Graph
g ]
outdegree :: Graph -> Array Vertex Int
outdegree :: Graph -> Array Vertex Vertex
outdegree = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t a -> Vertex
length
indegree :: Graph -> Array Vertex Int
indegree :: Graph -> Array Vertex Vertex
indegree Graph
g = forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray forall a. Num a => a -> a -> a
(+) Vertex
0 (forall i e. Array i e -> (i, i)
bounds Graph
g) [(Vertex
v, Vertex
1) | (Vertex
_, [Vertex]
outs) <- forall i e. Ix i => Array i e -> [(i, e)]
assocs Graph
g, Vertex
v <- [Vertex]
outs]
graphFromEdges'
:: Ord key
=> [(node, key, [key])]
-> (Graph, Vertex -> (node, key, [key]))
graphFromEdges' :: forall key node.
Ord key =>
[(node, key, [key])] -> (Graph, Vertex -> (node, key, [key]))
graphFromEdges' [(node, key, [key])]
x = (Graph
a,Vertex -> (node, key, [key])
b) where
(Graph
a,Vertex -> (node, key, [key])
b,key -> Maybe Vertex
_) = forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
graphFromEdges [(node, key, [key])]
x
graphFromEdges
:: Ord key
=> [(node, key, [key])]
-> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
graphFromEdges :: forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
graphFromEdges [(node, key, [key])]
edges0
= (Graph
graph, \Vertex
v -> Array Vertex (node, key, [key])
vertex_map forall i e. Ix i => Array i e -> i -> e
! Vertex
v, key -> Maybe Vertex
key_vertex)
where
max_v :: Vertex
max_v = forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [(node, key, [key])]
edges0 forall a. Num a => a -> a -> a
- Vertex
1
bounds0 :: Edge
bounds0 = (Vertex
0,Vertex
max_v) :: (Vertex, Vertex)
sorted_edges :: [(node, key, [key])]
sorted_edges = forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy forall {a} {a} {c} {a} {c}.
Ord a =>
(a, a, c) -> (a, a, c) -> Ordering
lt [(node, key, [key])]
edges0
edges1 :: [(Vertex, (node, key, [key]))]
edges1 = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (,) [Vertex
0..] [(node, key, [key])]
sorted_edges
graph :: Graph
graph = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array Edge
bounds0 [(,) Vertex
v (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe key -> Maybe Vertex
key_vertex [key]
ks) | (,) Vertex
v (node
_, key
_, [key]
ks) <- [(Vertex, (node, key, [key]))]
edges1]
key_map :: Array Vertex key
key_map = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array Edge
bounds0 [(,) Vertex
v key
k | (,) Vertex
v (node
_, key
k, [key]
_ ) <- [(Vertex, (node, key, [key]))]
edges1]
vertex_map :: Array Vertex (node, key, [key])
vertex_map = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array Edge
bounds0 [(Vertex, (node, key, [key]))]
edges1
(a
_,a
k1,c
_) lt :: (a, a, c) -> (a, a, c) -> Ordering
`lt` (a
_,a
k2,c
_) = a
k1 forall a. Ord a => a -> a -> Ordering
`compare` a
k2
key_vertex :: key -> Maybe Vertex
key_vertex key
k = Vertex -> Vertex -> Maybe Vertex
findVertex Vertex
0 Vertex
max_v
where
findVertex :: Vertex -> Vertex -> Maybe Vertex
findVertex Vertex
a Vertex
b | Vertex
a forall a. Ord a => a -> a -> Bool
> Vertex
b
= forall a. Maybe a
Nothing
findVertex Vertex
a Vertex
b = case forall a. Ord a => a -> a -> Ordering
compare key
k (Array Vertex key
key_map forall i e. Ix i => Array i e -> i -> e
! Vertex
mid) of
Ordering
LT -> Vertex -> Vertex -> Maybe Vertex
findVertex Vertex
a (Vertex
midforall a. Num a => a -> a -> a
-Vertex
1)
Ordering
EQ -> forall a. a -> Maybe a
Just Vertex
mid
Ordering
GT -> Vertex -> Vertex -> Maybe Vertex
findVertex (Vertex
midforall a. Num a => a -> a -> a
+Vertex
1) Vertex
b
where
mid :: Vertex
mid = Vertex
a forall a. Num a => a -> a -> a
+ (Vertex
b forall a. Num a => a -> a -> a
- Vertex
a) forall a. Integral a => a -> a -> a
`div` Vertex
2
dff :: Graph -> Forest Vertex
dff :: Graph -> Forest Vertex
dff Graph
g = Graph -> [Vertex] -> Forest Vertex
dfs Graph
g (Graph -> [Vertex]
vertices Graph
g)
dfs :: Graph -> [Vertex] -> Forest Vertex
dfs :: Graph -> [Vertex] -> Forest Vertex
dfs Graph
g [Vertex]
vs = Edge -> Forest Vertex -> Forest Vertex
prune (forall i e. Array i e -> (i, i)
bounds Graph
g) (forall a b. (a -> b) -> [a] -> [b]
map (Graph -> Vertex -> Tree Vertex
generate Graph
g) [Vertex]
vs)
generate :: Graph -> Vertex -> Tree Vertex
generate :: Graph -> Vertex -> Tree Vertex
generate Graph
g Vertex
v = forall a. a -> [Tree a] -> Tree a
Node Vertex
v (forall a b. (a -> b) -> [a] -> [b]
map (Graph -> Vertex -> Tree Vertex
generate Graph
g) (Graph
gforall i e. Ix i => Array i e -> i -> e
!Vertex
v))
prune :: Bounds -> Forest Vertex -> Forest Vertex
prune :: Edge -> Forest Vertex -> Forest Vertex
prune Edge
bnds Forest Vertex
ts = forall a. Edge -> (forall s. SetM s a) -> a
run Edge
bnds (forall s. Forest Vertex -> SetM s (Forest Vertex)
chop Forest Vertex
ts)
chop :: Forest Vertex -> SetM s (Forest Vertex)
chop :: forall s. Forest Vertex -> SetM s (Forest Vertex)
chop [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
chop (Node Vertex
v Forest Vertex
ts : Forest Vertex
us)
= do
Bool
visited <- forall s. Vertex -> SetM s Bool
contains Vertex
v
if Bool
visited then
forall s. Forest Vertex -> SetM s (Forest Vertex)
chop Forest Vertex
us
else do
forall s. Vertex -> SetM s ()
include Vertex
v
Forest Vertex
as <- forall s. Forest Vertex -> SetM s (Forest Vertex)
chop Forest Vertex
ts
Forest Vertex
bs <- forall s. Forest Vertex -> SetM s (Forest Vertex)
chop Forest Vertex
us
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> [Tree a] -> Tree a
Node Vertex
v Forest Vertex
as forall a. a -> [a] -> [a]
: Forest Vertex
bs)
#if USE_ST_MONAD
#if USE_UNBOXED_ARRAYS
newtype SetM s a = SetM { runSetM :: STUArray s Vertex Bool -> ST s a }
#else
newtype SetM s a = SetM { forall s a. SetM s a -> STArray s Vertex Bool -> ST s a
runSetM :: STArray s Vertex Bool -> ST s a }
#endif
instance Monad (SetM s) where
return :: forall a. a -> SetM s a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE return #-}
SetM STArray s Vertex Bool -> ST s a
v >>= :: forall a b. SetM s a -> (a -> SetM s b) -> SetM s b
>>= a -> SetM s b
f = forall s a. (STArray s Vertex Bool -> ST s a) -> SetM s a
SetM forall a b. (a -> b) -> a -> b
$ \STArray s Vertex Bool
s -> do { a
x <- STArray s Vertex Bool -> ST s a
v STArray s Vertex Bool
s; forall s a. SetM s a -> STArray s Vertex Bool -> ST s a
runSetM (a -> SetM s b
f a
x) STArray s Vertex Bool
s }
{-# INLINE (>>=) #-}
instance Functor (SetM s) where
a -> b
f fmap :: forall a b. (a -> b) -> SetM s a -> SetM s b
`fmap` SetM STArray s Vertex Bool -> ST s a
v = forall s a. (STArray s Vertex Bool -> ST s a) -> SetM s a
SetM forall a b. (a -> b) -> a -> b
$ \STArray s Vertex Bool
s -> a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` STArray s Vertex Bool -> ST s a
v STArray s Vertex Bool
s
{-# INLINE fmap #-}
instance Applicative (SetM s) where
pure :: forall a. a -> SetM s a
pure a
x = forall s a. (STArray s Vertex Bool -> ST s a) -> SetM s a
SetM forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return a
x)
{-# INLINE pure #-}
SetM STArray s Vertex Bool -> ST s (a -> b)
f <*> :: forall a b. SetM s (a -> b) -> SetM s a -> SetM s b
<*> SetM STArray s Vertex Bool -> ST s a
v = forall s a. (STArray s Vertex Bool -> ST s a) -> SetM s a
SetM forall a b. (a -> b) -> a -> b
$ \STArray s Vertex Bool
s -> STArray s Vertex Bool -> ST s (a -> b)
f STArray s Vertex Bool
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` STArray s Vertex Bool -> ST s a
v STArray s Vertex Bool
s)
{-# INLINE (<*>) #-}
run :: Bounds -> (forall s. SetM s a) -> a
run :: forall a. Edge -> (forall s. SetM s a) -> a
run Edge
bnds forall s. SetM s a
act = forall a. (forall s. ST s a) -> a
runST (forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray Edge
bnds Bool
False forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s a. SetM s a -> STArray s Vertex Bool -> ST s a
runSetM forall s. SetM s a
act)
contains :: Vertex -> SetM s Bool
contains :: forall s. Vertex -> SetM s Bool
contains Vertex
v = forall s a. (STArray s Vertex Bool -> ST s a) -> SetM s a
SetM forall a b. (a -> b) -> a -> b
$ \ STArray s Vertex Bool
m -> forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Vertex Bool
m Vertex
v
include :: Vertex -> SetM s ()
include :: forall s. Vertex -> SetM s ()
include Vertex
v = forall s a. (STArray s Vertex Bool -> ST s a) -> SetM s a
SetM forall a b. (a -> b) -> a -> b
$ \ STArray s Vertex Bool
m -> forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Vertex Bool
m Vertex
v Bool
True
#else /* !USE_ST_MONAD */
newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) }
instance Monad (SetM s) where
return x = SetM $ \s -> (x, s)
SetM v >>= f = SetM $ \s -> case v s of (x, s') -> runSetM (f x) s'
instance Functor (SetM s) where
f `fmap` SetM v = SetM $ \s -> case v s of (x, s') -> (f x, s')
{-# INLINE fmap #-}
instance Applicative (SetM s) where
pure x = SetM $ \s -> (x, s)
{-# INLINE pure #-}
SetM f <*> SetM v = SetM $ \s -> case f s of (k, s') -> case v s' of (x, s'') -> (k x, s'')
{-# INLINE (<*>) #-}
run :: Bounds -> SetM s a -> a
run _ act = fst (runSetM act Set.empty)
contains :: Vertex -> SetM s Bool
contains v = SetM $ \ m -> (Set.member v m, m)
include :: Vertex -> SetM s ()
include v = SetM $ \ m -> ((), Set.insert v m)
#endif /* !USE_ST_MONAD */
preorder' :: Tree a -> [a] -> [a]
preorder' :: forall a. Tree a -> [a] -> [a]
preorder' (Node a
a [Tree a]
ts) = (a
a forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Forest a -> [a] -> [a]
preorderF' [Tree a]
ts
preorderF' :: Forest a -> [a] -> [a]
preorderF' :: forall a. Forest a -> [a] -> [a]
preorderF' Forest a
ts = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Tree a -> [a] -> [a]
preorder' Forest a
ts
preorderF :: Forest a -> [a]
preorderF :: forall a. Forest a -> [a]
preorderF Forest a
ts = forall a. Forest a -> [a] -> [a]
preorderF' Forest a
ts []
tabulate :: Bounds -> [Vertex] -> UArray Vertex Int
tabulate :: Edge -> [Vertex] -> Array Vertex Vertex
tabulate Edge
bnds [Vertex]
vs = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
UA.array Edge
bnds (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,)) [Vertex
1..] [Vertex]
vs)
preArr :: Bounds -> Forest Vertex -> UArray Vertex Int
preArr :: Edge -> Forest Vertex -> Array Vertex Vertex
preArr Edge
bnds = Edge -> [Vertex] -> Array Vertex Vertex
tabulate Edge
bnds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Forest a -> [a]
preorderF
postorder :: Tree a -> [a] -> [a]
postorder :: forall a. Tree a -> [a] -> [a]
postorder (Node a
a [Tree a]
ts) = forall a. Forest a -> [a] -> [a]
postorderF [Tree a]
ts forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
a forall a. a -> [a] -> [a]
:)
postorderF :: Forest a -> [a] -> [a]
postorderF :: forall a. Forest a -> [a] -> [a]
postorderF Forest a
ts = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Tree a -> [a] -> [a]
postorder Forest a
ts
postOrd :: Graph -> [Vertex]
postOrd :: Graph -> [Vertex]
postOrd Graph
g = forall a. Forest a -> [a] -> [a]
postorderF (Graph -> Forest Vertex
dff Graph
g) []
topSort :: Graph -> [Vertex]
topSort :: Graph -> [Vertex]
topSort = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [Vertex]
postOrd
reverseTopSort :: Graph -> [Vertex]
reverseTopSort :: Graph -> [Vertex]
reverseTopSort = Graph -> [Vertex]
postOrd
components :: Graph -> Forest Vertex
components :: Graph -> Forest Vertex
components = Graph -> Forest Vertex
dff forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> Graph
undirected
undirected :: Graph -> Graph
undirected :: Graph -> Graph
undirected Graph
g = Edge -> [Edge] -> Graph
buildG (forall i e. Array i e -> (i, i)
bounds Graph
g) (Graph -> [Edge]
edges Graph
g forall a. [a] -> [a] -> [a]
++ Graph -> [Edge]
reverseE Graph
g)
scc :: Graph -> Forest Vertex
scc :: Graph -> Forest Vertex
scc Graph
g = Graph -> [Vertex] -> Forest Vertex
dfs Graph
g (forall a. [a] -> [a]
reverse (Graph -> [Vertex]
postOrd (Graph -> Graph
transposeG Graph
g)))
reachable :: Graph -> Vertex -> [Vertex]
reachable :: Graph -> Vertex -> [Vertex]
reachable Graph
g Vertex
v = forall a. Forest a -> [a]
preorderF (Graph -> [Vertex] -> Forest Vertex
dfs Graph
g [Vertex
v])
path :: Graph -> Vertex -> Vertex -> Bool
path :: Graph -> Vertex -> Vertex -> Bool
path Graph
g Vertex
v Vertex
w = Vertex
w forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Graph -> Vertex -> [Vertex]
reachable Graph
g Vertex
v)
bcc :: Graph -> Forest [Vertex]
bcc :: Graph -> Forest [Vertex]
bcc Graph
g = (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Tree (Vertex, Vertex, Vertex) -> Forest [Vertex]
bicomps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Graph
-> Array Vertex Vertex
-> Tree Vertex
-> Tree (Vertex, Vertex, Vertex)
do_label Graph
g Array Vertex Vertex
dnum)) Forest Vertex
forest
where forest :: Forest Vertex
forest = Graph -> Forest Vertex
dff Graph
g
dnum :: Array Vertex Vertex
dnum = Edge -> Forest Vertex -> Array Vertex Vertex
preArr (forall i e. Array i e -> (i, i)
bounds Graph
g) Forest Vertex
forest
do_label :: Graph -> UArray Vertex Int -> Tree Vertex -> Tree (Vertex,Int,Int)
do_label :: Graph
-> Array Vertex Vertex
-> Tree Vertex
-> Tree (Vertex, Vertex, Vertex)
do_label Graph
g Array Vertex Vertex
dnum (Node Vertex
v Forest Vertex
ts) = forall a. a -> [Tree a] -> Tree a
Node (Vertex
v, Array Vertex Vertex
dnum forall i e. Ix i => Array i e -> i -> e
UA.! Vertex
v, Vertex
lv) [Tree (Vertex, Vertex, Vertex)]
us
where us :: [Tree (Vertex, Vertex, Vertex)]
us = forall a b. (a -> b) -> [a] -> [b]
map (Graph
-> Array Vertex Vertex
-> Tree Vertex
-> Tree (Vertex, Vertex, Vertex)
do_label Graph
g Array Vertex Vertex
dnum) Forest Vertex
ts
lv :: Vertex
lv = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Array Vertex Vertex
dnum forall i e. Ix i => Array i e -> i -> e
UA.! Vertex
v] forall a. [a] -> [a] -> [a]
++ [Array Vertex Vertex
dnum forall i e. Ix i => Array i e -> i -> e
UA.! Vertex
w | Vertex
w <- Graph
gforall i e. Ix i => Array i e -> i -> e
!Vertex
v]
forall a. [a] -> [a] -> [a]
++ [Vertex
lu | Node (Vertex
_,Vertex
_,Vertex
lu) [Tree (Vertex, Vertex, Vertex)]
_ <- [Tree (Vertex, Vertex, Vertex)]
us])
bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
bicomps :: Tree (Vertex, Vertex, Vertex) -> Forest [Vertex]
bicomps (Node (Vertex
v,Vertex
_,Vertex
_) [Tree (Vertex, Vertex, Vertex)]
ts)
= [ forall a. a -> [Tree a] -> Tree a
Node (Vertex
vforall a. a -> [a] -> [a]
:[Vertex]
vs) Forest [Vertex]
us | (Vertex
_,Node [Vertex]
vs Forest [Vertex]
us) <- forall a b. (a -> b) -> [a] -> [b]
map Tree (Vertex, Vertex, Vertex) -> (Vertex, Tree [Vertex])
collect [Tree (Vertex, Vertex, Vertex)]
ts]
collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
collect :: Tree (Vertex, Vertex, Vertex) -> (Vertex, Tree [Vertex])
collect (Node (Vertex
v,Vertex
dv,Vertex
lv) [Tree (Vertex, Vertex, Vertex)]
ts) = (Vertex
lv, forall a. a -> [Tree a] -> Tree a
Node (Vertex
vforall a. a -> [a] -> [a]
:[Vertex]
vs) Forest [Vertex]
cs)
where collected :: [(Vertex, Tree [Vertex])]
collected = forall a b. (a -> b) -> [a] -> [b]
map Tree (Vertex, Vertex, Vertex) -> (Vertex, Tree [Vertex])
collect [Tree (Vertex, Vertex, Vertex)]
ts
vs :: [Vertex]
vs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Vertex]
ws | (Vertex
lw, Node [Vertex]
ws Forest [Vertex]
_) <- [(Vertex, Tree [Vertex])]
collected, Vertex
lwforall a. Ord a => a -> a -> Bool
<Vertex
dv]
cs :: Forest [Vertex]
cs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ if Vertex
lwforall a. Ord a => a -> a -> Bool
<Vertex
dv then Forest [Vertex]
us else [forall a. a -> [Tree a] -> Tree a
Node (Vertex
vforall a. a -> [a] -> [a]
:[Vertex]
ws) Forest [Vertex]
us]
| (Vertex
lw, Node [Vertex]
ws Forest [Vertex]
us) <- [(Vertex, Tree [Vertex])]
collected ]