{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE Strict #-}
#endif
module Data.Graph.Dom (
Node,Path,Edge
,Graph,Rooted
,idom,ipdom
,domTree,pdomTree
,dom,pdom
,pddfs,rpddfs
,fromAdj,fromEdges
,toAdj,toEdges
,asTree,asGraph
,parents,ancestors
) where
import Data.Monoid(Monoid(..))
import Data.Tuple (swap)
import Data.Tree
import Data.List
import Data.IntMap(IntMap)
import Data.IntSet(IntSet)
import qualified Data.IntSet as IS
import Control.Applicative
import Control.Monad
#if MIN_VERSION_containers(0, 5, 0)
import qualified Data.IntMap.Strict as IM
import Control.Monad.ST.Strict
#else
import qualified Data.IntMap as IM
import Control.Monad.ST
#endif
import Data.Array.ST
import Data.Array.Base
(unsafeNewArray_
,unsafeWrite,unsafeRead)
type Node = Int
type Path = [Node]
type Edge = (Node,Node)
type Graph = IntMap IntSet
type Rooted = (Node, Graph)
dom :: Rooted -> [(Node, Path)]
dom :: Rooted -> [(Node, Path)]
dom = Tree Node -> [(Node, Path)]
forall a. Tree a -> [(a, [a])]
ancestors (Tree Node -> [(Node, Path)])
-> (Rooted -> Tree Node) -> Rooted -> [(Node, Path)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Node
domTree
pdom :: Rooted -> [(Node, Path)]
pdom :: Rooted -> [(Node, Path)]
pdom = Tree Node -> [(Node, Path)]
forall a. Tree a -> [(a, [a])]
ancestors (Tree Node -> [(Node, Path)])
-> (Rooted -> Tree Node) -> Rooted -> [(Node, Path)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Node
pdomTree
domTree :: Rooted -> Tree Node
domTree :: Rooted -> Tree Node
domTree a :: Rooted
a@(Node
r,Graph
_) =
let is :: [(Node, Node)]
is = ((Node, Node) -> Bool) -> [(Node, Node)] -> [(Node, Node)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
/=Node
r)(Node -> Bool) -> ((Node, Node) -> Node) -> (Node, Node) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Node, Node) -> Node
forall a b. (a, b) -> a
fst) (Rooted -> [(Node, Node)]
idom Rooted
a)
tg :: Graph
tg = [(Node, Node)] -> Graph
fromEdges (((Node, Node) -> (Node, Node)) -> [(Node, Node)] -> [(Node, Node)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Node, Node) -> (Node, Node)
forall a b. (a, b) -> (b, a)
swap [(Node, Node)]
is)
in Rooted -> Tree Node
asTree (Node
r,Graph
tg)
pdomTree :: Rooted -> Tree Node
pdomTree :: Rooted -> Tree Node
pdomTree a :: Rooted
a@(Node
r,Graph
_) =
let is :: [(Node, Node)]
is = ((Node, Node) -> Bool) -> [(Node, Node)] -> [(Node, Node)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
/=Node
r)(Node -> Bool) -> ((Node, Node) -> Node) -> (Node, Node) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Node, Node) -> Node
forall a b. (a, b) -> a
fst) (Rooted -> [(Node, Node)]
ipdom Rooted
a)
tg :: Graph
tg = [(Node, Node)] -> Graph
fromEdges (((Node, Node) -> (Node, Node)) -> [(Node, Node)] -> [(Node, Node)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Node, Node) -> (Node, Node)
forall a b. (a, b) -> (b, a)
swap [(Node, Node)]
is)
in Rooted -> Tree Node
asTree (Node
r,Graph
tg)
idom :: Rooted -> [(Node,Node)]
idom :: Rooted -> [(Node, Node)]
idom Rooted
rg = (forall s. ST s [(Node, Node)]) -> [(Node, Node)]
forall a. (forall s. ST s a) -> a
runST (S s (Env s) [(Node, Node)] -> Env s -> ST s [(Node, Node)]
forall z s a. S z s a -> s -> ST z a
evalS S s (Env s) [(Node, Node)]
forall s. Dom s [(Node, Node)]
idomM (Env s -> ST s [(Node, Node)])
-> ST s (Env s) -> ST s [(Node, Node)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Rooted -> ST s (Env s)
forall s. Rooted -> ST s (Env s)
initEnv (Rooted -> Rooted
pruneReach Rooted
rg))
ipdom :: Rooted -> [(Node,Node)]
ipdom :: Rooted -> [(Node, Node)]
ipdom Rooted
rg = (forall s. ST s [(Node, Node)]) -> [(Node, Node)]
forall a. (forall s. ST s a) -> a
runST (S s (Env s) [(Node, Node)] -> Env s -> ST s [(Node, Node)]
forall z s a. S z s a -> s -> ST z a
evalS S s (Env s) [(Node, Node)]
forall s. Dom s [(Node, Node)]
idomM (Env s -> ST s [(Node, Node)])
-> ST s (Env s) -> ST s [(Node, Node)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Rooted -> ST s (Env s)
forall s. Rooted -> ST s (Env s)
initEnv (Rooted -> Rooted
pruneReach ((Graph -> Graph) -> Rooted -> Rooted
forall b c a. (b -> c) -> (a, b) -> (a, c)
second Graph -> Graph
predG Rooted
rg)))
pddfs :: Rooted -> [Node]
pddfs :: Rooted -> Path
pddfs = Path -> Path
forall a. [a] -> [a]
reverse (Path -> Path) -> (Rooted -> Path) -> Rooted -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Path
rpddfs
rpddfs :: Rooted -> [Node]
rpddfs :: Rooted -> Path
rpddfs = [Path] -> Path
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Path] -> Path) -> (Rooted -> [Path]) -> Rooted -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Node -> [Path]
forall a. Tree a -> [[a]]
levels (Tree Node -> [Path]) -> (Rooted -> Tree Node) -> Rooted -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Node
pdomTree
type Dom s a = S s (Env s) a
type NodeSet = IntSet
type NodeMap a = IntMap a
data Env s = Env
{Env s -> Graph
succE :: !Graph
,Env s -> Graph
predE :: !Graph
,Env s -> Graph
bucketE :: !Graph
,Env s -> Node
dfsE :: {-# UNPACK #-}!Int
,Env s -> Node
zeroE :: {-# UNPACK #-}!Node
,Env s -> Node
rootE :: {-# UNPACK #-}!Node
,Env s -> Arr s Node
labelE :: {-# UNPACK #-}!(Arr s Node)
,Env s -> Arr s Node
parentE :: {-# UNPACK #-}!(Arr s Node)
,Env s -> Arr s Node
ancestorE :: {-# UNPACK #-}!(Arr s Node)
,Env s -> Arr s Node
childE :: {-# UNPACK #-}!(Arr s Node)
,Env s -> Arr s Node
ndfsE :: {-# UNPACK #-}!(Arr s Node)
,Env s -> Arr s Node
dfnE :: {-# UNPACK #-}!(Arr s Int)
,Env s -> Arr s Node
sdnoE :: {-# UNPACK #-}!(Arr s Int)
,Env s -> Arr s Node
sizeE :: {-# UNPACK #-}!(Arr s Int)
,Env s -> Arr s Node
domE :: {-# UNPACK #-}!(Arr s Node)
,Env s -> Arr s Node
rnE :: {-# UNPACK #-}!(Arr s Node)}
idomM :: Dom s [(Node,Node)]
idomM :: Dom s [(Node, Node)]
idomM = do
Node -> Dom s ()
forall s. Node -> Dom s ()
dfsDom (Node -> Dom s ()) -> S s (Env s) Node -> Dom s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< S s (Env s) Node
forall s. Dom s Node
rootM
Node
n <- (Env s -> Node) -> S s (Env s) Node
forall s a z. (s -> a) -> S z s a
gets Env s -> Node
forall s. Env s -> Node
dfsE
Path -> (Node -> Dom s ()) -> Dom s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node
n,Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
-Node
1..Node
1] (\Node
i-> do
Node
w <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
ndfsM Node
i
Path
ps <- Node -> Dom s Path
forall s. Node -> Dom s Path
predsM Node
w
Path -> (Node -> Dom s ()) -> Dom s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Path
ps (\Node
v-> do
Node
sw <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
sdnoM Node
w
Node
u <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
eval Node
v
Node
su <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
sdnoM Node
u
Bool -> Dom s () -> Dom s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Node
su Node -> Node -> Bool
forall a. Ord a => a -> a -> Bool
< Node
sw)
((Env s -> Arr s Node) -> Node -> Node -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
sdnoE Node
w Node
su))
Node
z <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
ndfsM (Node -> S s (Env s) Node) -> S s (Env s) Node -> S s (Env s) Node
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node -> S s (Env s) Node
forall s. Node -> Dom s Node
sdnoM Node
w
(Env s -> Env s) -> Dom s ()
forall s z. (s -> s) -> S z s ()
modify(\Env s
e->Env s
e{bucketE :: Graph
bucketE=(IntSet -> IntSet) -> Node -> Graph -> Graph
forall a. (a -> a) -> Node -> IntMap a -> IntMap a
IM.adjust
(Node
wNode -> IntSet -> IntSet
`IS.insert`)
Node
z (Env s -> Graph
forall s. Env s -> Graph
bucketE Env s
e)})
Node
pw <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
parentM Node
w
Node -> Node -> Dom s ()
forall s. Node -> Node -> Dom s ()
link Node
pw Node
w
Path
bps <- Node -> Dom s Path
forall s. Node -> Dom s Path
bucketM Node
pw
Path -> (Node -> Dom s ()) -> Dom s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Path
bps (\Node
v-> do
Node
u <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
eval Node
v
Node
su <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
sdnoM Node
u
Node
sv <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
sdnoM Node
v
let dv :: Node
dv = case Node
su Node -> Node -> Bool
forall a. Ord a => a -> a -> Bool
< Node
sv of
Bool
True-> Node
u
Bool
False-> Node
pw
(Env s -> Arr s Node) -> Node -> Node -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
domE Node
v Node
dv))
Path -> (Node -> Dom s ()) -> Dom s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node
1..Node
n] (\Node
i-> do
Node
w <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
ndfsM Node
i
Node
j <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
sdnoM Node
w
Node
z <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
ndfsM Node
j
Node
dw <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
domM Node
w
Bool -> Dom s () -> Dom s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Node
dw Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
/= Node
z)
(do Node
ddw <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
domM Node
dw
(Env s -> Arr s Node) -> Node -> Node -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
domE Node
w Node
ddw))
Dom s [(Node, Node)]
forall s. Dom s [(Node, Node)]
fromEnv
eval :: Node -> Dom s Node
eval :: Node -> Dom s Node
eval Node
v = do
Node
n0 <- Dom s Node
forall s. Dom s Node
zeroM
Node
a <- Node -> Dom s Node
forall s. Node -> Dom s Node
ancestorM Node
v
case Node
aNode -> Node -> Bool
forall a. Eq a => a -> a -> Bool
==Node
n0 of
Bool
True-> Node -> Dom s Node
forall s. Node -> Dom s Node
labelM Node
v
Bool
False-> do
Node -> Dom s ()
forall s. Node -> Dom s ()
compress Node
v
Node
a <- Node -> Dom s Node
forall s. Node -> Dom s Node
ancestorM Node
v
Node
l <- Node -> Dom s Node
forall s. Node -> Dom s Node
labelM Node
v
Node
la <- Node -> Dom s Node
forall s. Node -> Dom s Node
labelM Node
a
Node
sl <- Node -> Dom s Node
forall s. Node -> Dom s Node
sdnoM Node
l
Node
sla <- Node -> Dom s Node
forall s. Node -> Dom s Node
sdnoM Node
la
case Node
sl Node -> Node -> Bool
forall a. Ord a => a -> a -> Bool
<= Node
sla of
Bool
True-> Node -> Dom s Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
l
Bool
False-> Node -> Dom s Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
la
compress :: Node -> Dom s ()
compress :: Node -> Dom s ()
compress Node
v = do
Node
n0 <- Dom s Node
forall s. Dom s Node
zeroM
Node
a <- Node -> Dom s Node
forall s. Node -> Dom s Node
ancestorM Node
v
Node
aa <- Node -> Dom s Node
forall s. Node -> Dom s Node
ancestorM Node
a
Bool -> Dom s () -> Dom s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Node
aa Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
/= Node
n0) (do
Node -> Dom s ()
forall s. Node -> Dom s ()
compress Node
a
Node
a <- Node -> Dom s Node
forall s. Node -> Dom s Node
ancestorM Node
v
Node
aa <- Node -> Dom s Node
forall s. Node -> Dom s Node
ancestorM Node
a
Node
l <- Node -> Dom s Node
forall s. Node -> Dom s Node
labelM Node
v
Node
la <- Node -> Dom s Node
forall s. Node -> Dom s Node
labelM Node
a
Node
sl <- Node -> Dom s Node
forall s. Node -> Dom s Node
sdnoM Node
l
Node
sla <- Node -> Dom s Node
forall s. Node -> Dom s Node
sdnoM Node
la
Bool -> Dom s () -> Dom s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Node
sla Node -> Node -> Bool
forall a. Ord a => a -> a -> Bool
< Node
sl)
((Env s -> Arr s Node) -> Node -> Node -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
labelE Node
v Node
la)
(Env s -> Arr s Node) -> Node -> Node -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
ancestorE Node
v Node
aa)
link :: Node -> Node -> Dom s ()
link :: Node -> Node -> Dom s ()
link Node
v Node
w = do
Node
n0 <- Dom s Node
forall s. Dom s Node
zeroM
Node
lw <- Node -> Dom s Node
forall s. Node -> Dom s Node
labelM Node
w
Node
slw <- Node -> Dom s Node
forall s. Node -> Dom s Node
sdnoM Node
lw
let balance :: Node -> S s (Env s) Node
balance Node
s = do
Node
c <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
childM Node
s
Node
lc <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
labelM Node
c
Node
slc <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
sdnoM Node
lc
case Node
slw Node -> Node -> Bool
forall a. Ord a => a -> a -> Bool
< Node
slc of
Bool
False-> Node -> S s (Env s) Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
s
Bool
True-> do
Node
zs <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
sizeM Node
s
Node
zc <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
sizeM Node
c
Node
cc <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
childM Node
c
Node
zcc <- Node -> S s (Env s) Node
forall s. Node -> Dom s Node
sizeM Node
cc
case Node
2Node -> Node -> Node
forall a. Num a => a -> a -> a
*Node
zc Node -> Node -> Bool
forall a. Ord a => a -> a -> Bool
<= Node
zsNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
zcc of
Bool
True-> do
(Env s -> Arr s Node) -> Node -> Node -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
ancestorE Node
c Node
s
(Env s -> Arr s Node) -> Node -> Node -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
childE Node
s Node
cc
Node -> S s (Env s) Node
balance Node
s
Bool
False-> do
(Env s -> Arr s Node) -> Node -> Node -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
sizeE Node
c Node
zs
(Env s -> Arr s Node) -> Node -> Node -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
ancestorE Node
s Node
c
Node -> S s (Env s) Node
balance Node
c
Node
s <- Node -> Dom s Node
forall s. Node -> Dom s Node
balance Node
w
Node
lw <- Node -> Dom s Node
forall s. Node -> Dom s Node
labelM Node
w
Node
zw <- Node -> Dom s Node
forall s. Node -> Dom s Node
sizeM Node
w
(Env s -> Arr s Node) -> Node -> Node -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
labelE Node
s Node
lw
(Env s -> Arr s Node) -> Node -> Node -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
sizeE Node
v (Node -> Dom s ()) -> (Node -> Node) -> Node -> Dom s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Node -> Node
forall a. Num a => a -> a -> a
+Node
zw) (Node -> Dom s ()) -> Dom s Node -> Dom s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node -> Dom s Node
forall s. Node -> Dom s Node
sizeM Node
v
let follow :: Node -> S z (Env z) ()
follow Node
s = do
Bool -> S z (Env z) () -> S z (Env z) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Node
s Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
/= Node
n0) (do
(Env z -> Arr z Node) -> Node -> Node -> S z (Env z) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env z -> Arr z Node
forall s. Env s -> Arr s Node
ancestorE Node
s Node
v
Node -> S z (Env z) ()
follow (Node -> S z (Env z) ()) -> S z (Env z) Node -> S z (Env z) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node -> S z (Env z) Node
forall s. Node -> Dom s Node
childM Node
s)
Node
zv <- Node -> Dom s Node
forall s. Node -> Dom s Node
sizeM Node
v
Node -> Dom s ()
forall s. Node -> Dom s ()
follow (Node -> Dom s ()) -> Dom s Node -> Dom s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Node
zv Node -> Node -> Bool
forall a. Ord a => a -> a -> Bool
< Node
2Node -> Node -> Node
forall a. Num a => a -> a -> a
*Node
zw of
Bool
False-> Node -> Dom s Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
s
Bool
True-> do
Node
cv <- Node -> Dom s Node
forall s. Node -> Dom s Node
childM Node
v
(Env s -> Arr s Node) -> Node -> Node -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
childE Node
v Node
s
Node -> Dom s Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
cv
dfsDom :: Node -> Dom s ()
dfsDom :: Node -> Dom s ()
dfsDom Node
i = do
()
_ <- Node -> Dom s ()
forall s. Node -> Dom s ()
go Node
i
Node
n0 <- Dom s Node
forall s. Dom s Node
zeroM
Node
r <- Dom s Node
forall s. Dom s Node
rootM
(Env s -> Arr s Node) -> Node -> Node -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
parentE Node
r Node
n0
where go :: Node -> S s (Env s) ()
go Node
i = do
Node
n <- Dom s Node
forall s. Dom s Node
nextM
(Env s -> Arr s Node) -> Node -> Node -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
dfnE Node
i Node
n
(Env s -> Arr s Node) -> Node -> Node -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
sdnoE Node
i Node
n
(Env s -> Arr s Node) -> Node -> Node -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
ndfsE Node
n Node
i
(Env s -> Arr s Node) -> Node -> Node -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
labelE Node
i Node
i
Path
ss <- Node -> Dom s Path
forall s. Node -> Dom s Path
succsM Node
i
Path -> (Node -> S s (Env s) ()) -> S s (Env s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Path
ss (\Node
j-> do
Node
s <- Node -> Dom s Node
forall s. Node -> Dom s Node
sdnoM Node
j
case Node
sNode -> Node -> Bool
forall a. Eq a => a -> a -> Bool
==Node
0 of
Bool
False-> () -> S s (Env s) ()
forall (m :: * -> *) a. Monad m => a -> m a
return()
Bool
True-> do
(Env s -> Arr s Node) -> Node -> Node -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> a -> S z s ()
store Env s -> Arr s Node
forall s. Env s -> Arr s Node
parentE Node
j Node
i
Node -> S s (Env s) ()
go Node
j)
initEnv :: Rooted -> ST s (Env s)
initEnv :: Rooted -> ST s (Env s)
initEnv (Node
r0,Graph
g0) = do
let (Graph
g,NodeMap Node
rnmap) = Node -> Graph -> (Graph, NodeMap Node)
renum Node
1 Graph
g0
pred :: Graph
pred = Graph -> Graph
predG Graph
g
root :: Node
root = NodeMap Node
rnmap NodeMap Node -> Node -> Node
forall a. IntMap a -> Node -> a
IM.! Node
r0
n :: Node
n = Graph -> Node
forall a. IntMap a -> Node
IM.size Graph
g
ns :: Path
ns = [Node
0..Node
n]
m :: Node
m = Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
1
let bucket :: Graph
bucket = [(Node, IntSet)] -> Graph
forall a. [(Node, a)] -> IntMap a
IM.fromList
(Path -> [IntSet] -> [(Node, IntSet)]
forall a b. [a] -> [b] -> [(a, b)]
zip Path
ns (IntSet -> [IntSet]
forall a. a -> [a]
repeat IntSet
forall a. Monoid a => a
mempty))
Arr s Node
rna <- Node -> ST s (Arr s Node)
forall s. Node -> ST s (Arr s Node)
newI Node
m
Arr s Node -> [(Node, Node)] -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> [(Node, a)] -> ST s ()
writes Arr s Node
rna (((Node, Node) -> (Node, Node)) -> [(Node, Node)] -> [(Node, Node)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Node, Node) -> (Node, Node)
forall a b. (a, b) -> (b, a)
swap
(NodeMap Node -> [(Node, Node)]
forall a. IntMap a -> [(Node, a)]
IM.toList NodeMap Node
rnmap))
Arr s Node
doms <- Node -> ST s (Arr s Node)
forall s. Node -> ST s (Arr s Node)
newI Node
m
Arr s Node
sdno <- Node -> ST s (Arr s Node)
forall s. Node -> ST s (Arr s Node)
newI Node
m
Arr s Node
size <- Node -> ST s (Arr s Node)
forall s. Node -> ST s (Arr s Node)
newI Node
m
Arr s Node
parent <- Node -> ST s (Arr s Node)
forall s. Node -> ST s (Arr s Node)
newI Node
m
Arr s Node
ancestor <- Node -> ST s (Arr s Node)
forall s. Node -> ST s (Arr s Node)
newI Node
m
Arr s Node
child <- Node -> ST s (Arr s Node)
forall s. Node -> ST s (Arr s Node)
newI Node
m
Arr s Node
label <- Node -> ST s (Arr s Node)
forall s. Node -> ST s (Arr s Node)
newI Node
m
Arr s Node
ndfs <- Node -> ST s (Arr s Node)
forall s. Node -> ST s (Arr s Node)
newI Node
m
Arr s Node
dfn <- Node -> ST s (Arr s Node)
forall s. Node -> ST s (Arr s Node)
newI Node
m
Path -> (Node -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node
0..Node
n] (Arr s Node
domsArr s Node -> Node -> Node -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=Node
0)
Path -> (Node -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node
0..Node
n] (Arr s Node
sdnoArr s Node -> Node -> Node -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=Node
0)
Path -> (Node -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node
1..Node
n] (Arr s Node
sizeArr s Node -> Node -> Node -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=Node
1)
Path -> (Node -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node
0..Node
n] (Arr s Node
ancestorArr s Node -> Node -> Node -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=Node
0)
Path -> (Node -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node
0..Node
n] (Arr s Node
childArr s Node -> Node -> Node -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=Node
0)
(Arr s Node
domsArr s Node -> Node -> Node -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=Node
root) Node
root
(Arr s Node
sizeArr s Node -> Node -> Node -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=Node
0) Node
0
(Arr s Node
labelArr s Node -> Node -> Node -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=Node
0) Node
0
Env s -> ST s (Env s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env :: forall s.
Graph
-> Graph
-> Graph
-> Node
-> Node
-> Node
-> Arr s Node
-> Arr s Node
-> Arr s Node
-> Arr s Node
-> Arr s Node
-> Arr s Node
-> Arr s Node
-> Arr s Node
-> Arr s Node
-> Arr s Node
-> Env s
Env
{rnE :: Arr s Node
rnE = Arr s Node
rna
,dfsE :: Node
dfsE = Node
0
,zeroE :: Node
zeroE = Node
0
,rootE :: Node
rootE = Node
root
,labelE :: Arr s Node
labelE = Arr s Node
label
,parentE :: Arr s Node
parentE = Arr s Node
parent
,ancestorE :: Arr s Node
ancestorE = Arr s Node
ancestor
,childE :: Arr s Node
childE = Arr s Node
child
,ndfsE :: Arr s Node
ndfsE = Arr s Node
ndfs
,dfnE :: Arr s Node
dfnE = Arr s Node
dfn
,sdnoE :: Arr s Node
sdnoE = Arr s Node
sdno
,sizeE :: Arr s Node
sizeE = Arr s Node
size
,succE :: Graph
succE = Graph
g
,predE :: Graph
predE = Graph
pred
,bucketE :: Graph
bucketE = Graph
bucket
,domE :: Arr s Node
domE = Arr s Node
doms})
fromEnv :: Dom s [(Node,Node)]
fromEnv :: Dom s [(Node, Node)]
fromEnv = do
Arr s Node
dom <- (Env s -> Arr s Node) -> S s (Env s) (Arr s Node)
forall s a z. (s -> a) -> S z s a
gets Env s -> Arr s Node
forall s. Env s -> Arr s Node
domE
Arr s Node
rn <- (Env s -> Arr s Node) -> S s (Env s) (Arr s Node)
forall s a z. (s -> a) -> S z s a
gets Env s -> Arr s Node
forall s. Env s -> Arr s Node
rnE
(Node
_,Node
n) <- ST s (Node, Node) -> S s (Env s) (Node, Node)
forall z a s. ST z a -> S z s a
st (Arr s Node -> ST s (Node, Node)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds Arr s Node
dom)
Path -> (Node -> S s (Env s) (Node, Node)) -> Dom s [(Node, Node)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Node
1..Node
n] (\Node
i-> do
Node
j <- ST s Node -> S s (Env s) Node
forall z a s. ST z a -> S z s a
st(Arr s Node
rnArr s Node -> Node -> ST s Node
forall s a. MArray (A s) a (ST s) => A s Node a -> Node -> ST s a
!:Node
i)
Node
d <- ST s Node -> S s (Env s) Node
forall z a s. ST z a -> S z s a
st(Arr s Node
domArr s Node -> Node -> ST s Node
forall s a. MArray (A s) a (ST s) => A s Node a -> Node -> ST s a
!:Node
i)
Node
k <- ST s Node -> S s (Env s) Node
forall z a s. ST z a -> S z s a
st(Arr s Node
rnArr s Node -> Node -> ST s Node
forall s a. MArray (A s) a (ST s) => A s Node a -> Node -> ST s a
!:Node
d)
(Node, Node) -> S s (Env s) (Node, Node)
forall (m :: * -> *) a. Monad m => a -> m a
return (Node
j,Node
k))
zeroM :: Dom s Node
zeroM :: Dom s Node
zeroM = (Env s -> Node) -> Dom s Node
forall s a z. (s -> a) -> S z s a
gets Env s -> Node
forall s. Env s -> Node
zeroE
domM :: Node -> Dom s Node
domM :: Node -> Dom s Node
domM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
domE
rootM :: Dom s Node
rootM :: Dom s Node
rootM = (Env s -> Node) -> Dom s Node
forall s a z. (s -> a) -> S z s a
gets Env s -> Node
forall s. Env s -> Node
rootE
succsM :: Node -> Dom s [Node]
succsM :: Node -> Dom s Path
succsM Node
i = (Env s -> Path) -> Dom s Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph -> Node -> IntSet
forall a. Monoid a => IntMap a -> Node -> a
! Node
i) (Graph -> IntSet) -> (Env s -> Graph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> Graph
forall s. Env s -> Graph
succE)
predsM :: Node -> Dom s [Node]
predsM :: Node -> Dom s Path
predsM Node
i = (Env s -> Path) -> Dom s Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph -> Node -> IntSet
forall a. Monoid a => IntMap a -> Node -> a
! Node
i) (Graph -> IntSet) -> (Env s -> Graph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> Graph
forall s. Env s -> Graph
predE)
bucketM :: Node -> Dom s [Node]
bucketM :: Node -> Dom s Path
bucketM Node
i = (Env s -> Path) -> Dom s Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph -> Node -> IntSet
forall a. Monoid a => IntMap a -> Node -> a
! Node
i) (Graph -> IntSet) -> (Env s -> Graph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> Graph
forall s. Env s -> Graph
bucketE)
sizeM :: Node -> Dom s Int
sizeM :: Node -> Dom s Node
sizeM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
sizeE
sdnoM :: Node -> Dom s Int
sdnoM :: Node -> Dom s Node
sdnoM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
sdnoE
ndfsM :: Int -> Dom s Node
ndfsM :: Node -> Dom s Node
ndfsM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
ndfsE
childM :: Node -> Dom s Node
childM :: Node -> Dom s Node
childM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
childE
ancestorM :: Node -> Dom s Node
ancestorM :: Node -> Dom s Node
ancestorM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
ancestorE
parentM :: Node -> Dom s Node
parentM :: Node -> Dom s Node
parentM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
parentE
labelM :: Node -> Dom s Node
labelM :: Node -> Dom s Node
labelM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
labelE
nextM :: Dom s Int
nextM :: Dom s Node
nextM = do
Node
n <- (Env s -> Node) -> Dom s Node
forall s a z. (s -> a) -> S z s a
gets Env s -> Node
forall s. Env s -> Node
dfsE
let n' :: Node
n' = Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
1
(Env s -> Env s) -> S s (Env s) ()
forall s z. (s -> s) -> S z s ()
modify(\Env s
e->Env s
e{dfsE :: Node
dfsE=Node
n'})
Node -> Dom s Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
n'
type A = STUArray
type Arr s a = A s Int a
infixl 9 !:
infixr 2 .=
(.=) :: (MArray (A s) a (ST s))
=> Arr s a -> a -> Int -> ST s ()
(Arr s a
v .= :: Arr s a -> a -> Node -> ST s ()
.= a
x) Node
i = Arr s a -> Node -> a -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Node -> e -> m ()
unsafeWrite Arr s a
v Node
i a
x
(!:) :: (MArray (A s) a (ST s))
=> A s Int a -> Int -> ST s a
A s Node a
a !: :: A s Node a -> Node -> ST s a
!: Node
i = do
a
o <- A s Node a -> Node -> ST s a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Node -> m e
unsafeRead A s Node a
a Node
i
a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ST s a) -> a -> ST s a
forall a b. (a -> b) -> a -> b
$! a
o
new :: (MArray (A s) a (ST s))
=> Int -> ST s (Arr s a)
new :: Node -> ST s (Arr s a)
new Node
n = (Node, Node) -> ST s (Arr s a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
unsafeNewArray_ (Node
0,Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
-Node
1)
newI :: Int -> ST s (Arr s Int)
newI :: Node -> ST s (Arr s Node)
newI = Node -> ST s (Arr s Node)
forall s a. MArray (A s) a (ST s) => Node -> ST s (Arr s a)
new
writes :: (MArray (A s) a (ST s))
=> Arr s a -> [(Int,a)] -> ST s ()
writes :: Arr s a -> [(Node, a)] -> ST s ()
writes Arr s a
a [(Node, a)]
xs = [(Node, a)] -> ((Node, a) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Node, a)]
xs (\(Node
i,a
x) -> (Arr s a
aArr s a -> a -> Node -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=a
x) Node
i)
(!) :: Monoid a => IntMap a -> Int -> a
(!) IntMap a
g Node
n = a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
forall a. Monoid a => a
mempty a -> a
forall a. a -> a
id (Node -> IntMap a -> Maybe a
forall a. Node -> IntMap a -> Maybe a
IM.lookup Node
n IntMap a
g)
fromAdj :: [(Node, [Node])] -> Graph
fromAdj :: [(Node, Path)] -> Graph
fromAdj = [(Node, IntSet)] -> Graph
forall a. [(Node, a)] -> IntMap a
IM.fromList ([(Node, IntSet)] -> Graph)
-> ([(Node, Path)] -> [(Node, IntSet)]) -> [(Node, Path)] -> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Node, Path) -> (Node, IntSet))
-> [(Node, Path)] -> [(Node, IntSet)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Path -> IntSet) -> (Node, Path) -> (Node, IntSet)
forall b c a. (b -> c) -> (a, b) -> (a, c)
second Path -> IntSet
IS.fromList)
fromEdges :: [Edge] -> Graph
fromEdges :: [(Node, Node)] -> Graph
fromEdges = (IntSet -> IntSet -> IntSet)
-> ((Node, Node) -> Node)
-> ((Node, Node) -> IntSet)
-> [(Node, Node)]
-> Graph
forall c a.
(c -> c -> c) -> (a -> Node) -> (a -> c) -> [a] -> IntMap c
collectI IntSet -> IntSet -> IntSet
IS.union (Node, Node) -> Node
forall a b. (a, b) -> a
fst (Node -> IntSet
IS.singleton (Node -> IntSet)
-> ((Node, Node) -> Node) -> (Node, Node) -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, Node) -> Node
forall a b. (a, b) -> b
snd)
toAdj :: Graph -> [(Node, [Node])]
toAdj :: Graph -> [(Node, Path)]
toAdj = ((Node, IntSet) -> (Node, Path))
-> [(Node, IntSet)] -> [(Node, Path)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IntSet -> Path) -> (Node, IntSet) -> (Node, Path)
forall b c a. (b -> c) -> (a, b) -> (a, c)
second IntSet -> Path
IS.toList) ([(Node, IntSet)] -> [(Node, Path)])
-> (Graph -> [(Node, IntSet)]) -> Graph -> [(Node, Path)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [(Node, IntSet)]
forall a. IntMap a -> [(Node, a)]
IM.toList
toEdges :: Graph -> [Edge]
toEdges :: Graph -> [(Node, Node)]
toEdges = ((Node, Path) -> [(Node, Node)])
-> [(Node, Path)] -> [(Node, Node)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Node -> Path -> [(Node, Node)]) -> (Node, Path) -> [(Node, Node)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Node -> (Node, Node)) -> Path -> [(Node, Node)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Node -> (Node, Node)) -> Path -> [(Node, Node)])
-> (Node -> Node -> (Node, Node)) -> Node -> Path -> [(Node, Node)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,))) ([(Node, Path)] -> [(Node, Node)])
-> (Graph -> [(Node, Path)]) -> Graph -> [(Node, Node)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [(Node, Path)]
toAdj
predG :: Graph -> Graph
predG :: Graph -> Graph
predG Graph
g = (IntSet -> IntSet -> IntSet) -> Graph -> Graph -> Graph
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntSet -> IntSet -> IntSet
IS.union (Graph -> Graph
go Graph
g) Graph
g0
where g0 :: Graph
g0 = (IntSet -> IntSet) -> Graph -> Graph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IntSet -> IntSet -> IntSet
forall a b. a -> b -> a
const IntSet
forall a. Monoid a => a
mempty) Graph
g
go :: Graph -> Graph
go = ((Node -> IntSet -> Graph -> Graph) -> Graph -> Graph -> Graph)
-> Graph -> (Node -> IntSet -> Graph -> Graph) -> Graph -> Graph
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Node -> IntSet -> Graph -> Graph) -> Graph -> Graph -> Graph
forall a b. (Node -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey Graph
forall a. Monoid a => a
mempty (\Node
i IntSet
a Graph
m ->
(Graph -> Node -> Graph) -> Graph -> Path -> Graph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Graph
m Node
p -> (IntSet -> IntSet -> IntSet) -> Node -> IntSet -> Graph -> Graph
forall a. (a -> a -> a) -> Node -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
forall a. Monoid a => a -> a -> a
mappend Node
p
(Node -> IntSet
IS.singleton Node
i) Graph
m)
Graph
m
(IntSet -> Path
IS.toList IntSet
a))
pruneReach :: Rooted -> Rooted
pruneReach :: Rooted -> Rooted
pruneReach (Node
r,Graph
g) = (Node
r,Graph
g2)
where is :: IntSet
is = (Node -> IntSet) -> Node -> IntSet
reachable
(IntSet -> (IntSet -> IntSet) -> Maybe IntSet -> IntSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IntSet
forall a. Monoid a => a
mempty IntSet -> IntSet
forall a. a -> a
id
(Maybe IntSet -> IntSet)
-> (Node -> Maybe IntSet) -> Node -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Graph -> Maybe IntSet) -> Graph -> Node -> Maybe IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node -> Graph -> Maybe IntSet
forall a. Node -> IntMap a -> Maybe a
IM.lookup Graph
g) (Node -> IntSet) -> Node -> IntSet
forall a b. (a -> b) -> a -> b
$ Node
r
g2 :: Graph
g2 = [(Node, IntSet)] -> Graph
forall a. [(Node, a)] -> IntMap a
IM.fromList
([(Node, IntSet)] -> Graph)
-> (Graph -> [(Node, IntSet)]) -> Graph -> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Node, IntSet) -> (Node, IntSet))
-> [(Node, IntSet)] -> [(Node, IntSet)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IntSet -> IntSet) -> (Node, IntSet) -> (Node, IntSet)
forall b c a. (b -> c) -> (a, b) -> (a, c)
second ((Node -> Bool) -> IntSet -> IntSet
IS.filter (Node -> IntSet -> Bool
`IS.member`IntSet
is)))
([(Node, IntSet)] -> [(Node, IntSet)])
-> (Graph -> [(Node, IntSet)]) -> Graph -> [(Node, IntSet)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Node, IntSet) -> Bool) -> [(Node, IntSet)] -> [(Node, IntSet)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Node -> IntSet -> Bool
`IS.member`IntSet
is) (Node -> Bool)
-> ((Node, IntSet) -> Node) -> (Node, IntSet) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, IntSet) -> Node
forall a b. (a, b) -> a
fst)
([(Node, IntSet)] -> [(Node, IntSet)])
-> (Graph -> [(Node, IntSet)]) -> Graph -> [(Node, IntSet)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [(Node, IntSet)]
forall a. IntMap a -> [(Node, a)]
IM.toList (Graph -> Graph) -> Graph -> Graph
forall a b. (a -> b) -> a -> b
$ Graph
g
tip :: Tree a -> (a, [Tree a])
tip :: Tree a -> (a, [Tree a])
tip (Node a
a [Tree a]
ts) = (a
a, [Tree a]
ts)
parents :: Tree a -> [(a, a)]
parents :: Tree a -> [(a, a)]
parents (Node a
i Forest a
xs) = a -> Forest a -> [(a, a)]
forall (f :: * -> *) b a. Functor f => b -> f (Tree a) -> f (a, b)
p a
i Forest a
xs
[(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ (Tree a -> [(a, a)]) -> Forest a -> [(a, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [(a, a)]
forall a. Tree a -> [(a, a)]
parents Forest a
xs
where p :: b -> f (Tree a) -> f (a, b)
p b
i = (Tree a -> (a, b)) -> f (Tree a) -> f (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b -> (a, b)) -> b -> a -> (a, b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) b
i (a -> (a, b)) -> (Tree a -> a) -> Tree a -> (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> a
forall a. Tree a -> a
rootLabel)
ancestors :: Tree a -> [(a, [a])]
ancestors :: Tree a -> [(a, [a])]
ancestors = [a] -> Tree a -> [(a, [a])]
forall a. [a] -> Tree a -> [(a, [a])]
go []
where go :: [a] -> Tree a -> [(a, [a])]
go [a]
acc (Node a
i Forest a
xs)
= let acc' :: [a]
acc' = a
ia -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc
in [a] -> Forest a -> [(a, [a])]
forall (f :: * -> *) b a. Functor f => b -> f (Tree a) -> f (a, b)
p [a]
acc' Forest a
xs [(a, [a])] -> [(a, [a])] -> [(a, [a])]
forall a. [a] -> [a] -> [a]
++ (Tree a -> [(a, [a])]) -> Forest a -> [(a, [a])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([a] -> Tree a -> [(a, [a])]
go [a]
acc') Forest a
xs
p :: b -> f (Tree a) -> f (a, b)
p b
is = (Tree a -> (a, b)) -> f (Tree a) -> f (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b -> (a, b)) -> b -> a -> (a, b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) b
is (a -> (a, b)) -> (Tree a -> a) -> Tree a -> (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> a
forall a. Tree a -> a
rootLabel)
asGraph :: Tree Node -> Rooted
asGraph :: Tree Node -> Rooted
asGraph t :: Tree Node
t@(Node Node
a Forest Node
_) = let g :: [(Node, Path)]
g = Tree Node -> [(Node, Path)]
forall a. Tree a -> [(a, [a])]
go Tree Node
t in (Node
a, [(Node, Path)] -> Graph
fromAdj [(Node, Path)]
g)
where go :: Tree a -> [(a, [a])]
go (Node a
a Forest a
ts) = let as :: [a]
as = (([a], [Forest a]) -> [a]
forall a b. (a, b) -> a
fst (([a], [Forest a]) -> [a])
-> (Forest a -> ([a], [Forest a])) -> Forest a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, Forest a)] -> ([a], [Forest a])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(a, Forest a)] -> ([a], [Forest a]))
-> (Forest a -> [(a, Forest a)]) -> Forest a -> ([a], [Forest a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree a -> (a, Forest a)) -> Forest a -> [(a, Forest a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree a -> (a, Forest a)
forall a. Tree a -> (a, [Tree a])
tip) Forest a
ts
in (a
a, [a]
as) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: (Tree a -> [(a, [a])]) -> Forest a -> [(a, [a])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [(a, [a])]
go Forest a
ts
asTree :: Rooted -> Tree Node
asTree :: Rooted -> Tree Node
asTree (Node
r,Graph
g) = let go :: Node -> Tree Node
go Node
a = Node -> Forest Node -> Tree Node
forall a. a -> Forest a -> Tree a
Node Node
a ((Node -> Tree Node) -> Path -> Forest Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> Tree Node
go ((IntSet -> Path
IS.toList (IntSet -> Path) -> (Node -> IntSet) -> Node -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> IntSet
f) Node
a))
f :: Node -> IntSet
f = (Graph
g Graph -> Node -> IntSet
forall a. Monoid a => IntMap a -> Node -> a
!)
in Node -> Tree Node
go Node
r
reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
reachable :: (Node -> IntSet) -> Node -> IntSet
reachable Node -> IntSet
f Node
a = IntSet -> Node -> IntSet
go (Node -> IntSet
IS.singleton Node
a) Node
a
where go :: IntSet -> Node -> IntSet
go IntSet
seen Node
a = let s :: IntSet
s = Node -> IntSet
f Node
a
as :: Path
as = IntSet -> Path
IS.toList (IntSet
s IntSet -> IntSet -> IntSet
`IS.difference` IntSet
seen)
in (IntSet -> Node -> IntSet) -> IntSet -> Path -> IntSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntSet -> Node -> IntSet
go (IntSet
s IntSet -> IntSet -> IntSet
`IS.union` IntSet
seen) Path
as
collectI :: (c -> c -> c)
-> (a -> Int) -> (a -> c) -> [a] -> IntMap c
collectI :: (c -> c -> c) -> (a -> Node) -> (a -> c) -> [a] -> IntMap c
collectI c -> c -> c
(<>) a -> Node
f a -> c
g
= (IntMap c -> a -> IntMap c) -> IntMap c -> [a] -> IntMap c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\IntMap c
m a
a -> (c -> c -> c) -> Node -> c -> IntMap c -> IntMap c
forall a. (a -> a -> a) -> Node -> a -> IntMap a -> IntMap a
IM.insertWith c -> c -> c
(<>)
(a -> Node
f a
a)
(a -> c
g a
a) IntMap c
m) IntMap c
forall a. Monoid a => a
mempty
renum :: Int -> Graph -> (Graph, NodeMap Node)
renum :: Node -> Graph -> (Graph, NodeMap Node)
renum Node
from = (\(Node
_,NodeMap Node
m,Graph
g)->(Graph
g,NodeMap Node
m))
((Node, NodeMap Node, Graph) -> (Graph, NodeMap Node))
-> (Graph -> (Node, NodeMap Node, Graph))
-> Graph
-> (Graph, NodeMap Node)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node
-> IntSet
-> (Node, NodeMap Node, Graph)
-> (Node, NodeMap Node, Graph))
-> (Node, NodeMap Node, Graph)
-> Graph
-> (Node, NodeMap Node, Graph)
forall a b. (Node -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey
(\Node
i IntSet
ss (!Node
n,!NodeMap Node
env,!Graph
new)->
let (Node
j,Node
n2,NodeMap Node
env2) = Node -> NodeMap Node -> Node -> (Node, Node, NodeMap Node)
go Node
n NodeMap Node
env Node
i
(Node
n3,NodeMap Node
env3,IntSet
ss2) = (Node
-> (Node, NodeMap Node, IntSet) -> (Node, NodeMap Node, IntSet))
-> (Node, NodeMap Node, IntSet)
-> IntSet
-> (Node, NodeMap Node, IntSet)
forall b. (Node -> b -> b) -> b -> IntSet -> b
IS.fold
(\Node
k (!Node
n,!NodeMap Node
env,!IntSet
new)->
case Node -> NodeMap Node -> Node -> (Node, Node, NodeMap Node)
go Node
n NodeMap Node
env Node
k of
(Node
l,Node
n2,NodeMap Node
env2)-> (Node
n2,NodeMap Node
env2,Node
l Node -> IntSet -> IntSet
`IS.insert` IntSet
new))
(Node
n2,NodeMap Node
env2,IntSet
forall a. Monoid a => a
mempty) IntSet
ss
new2 :: Graph
new2 = (IntSet -> IntSet -> IntSet) -> Node -> IntSet -> Graph -> Graph
forall a. (a -> a -> a) -> Node -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
IS.union Node
j IntSet
ss2 Graph
new
in (Node
n3,NodeMap Node
env3,Graph
new2)) (Node
from,NodeMap Node
forall a. Monoid a => a
mempty,Graph
forall a. Monoid a => a
mempty)
where go :: Int
-> NodeMap Node
-> Node
-> (Node,Int,NodeMap Node)
go :: Node -> NodeMap Node -> Node -> (Node, Node, NodeMap Node)
go !Node
n !NodeMap Node
env Node
i =
case Node -> NodeMap Node -> Maybe Node
forall a. Node -> IntMap a -> Maybe a
IM.lookup Node
i NodeMap Node
env of
Just Node
j -> (Node
j,Node
n,NodeMap Node
env)
Maybe Node
Nothing -> (Node
n,Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
1,Node -> Node -> NodeMap Node -> NodeMap Node
forall a. Node -> a -> IntMap a -> IntMap a
IM.insert Node
i Node
n NodeMap Node
env)
newtype S z s a = S {S z s a -> forall o. (a -> s -> ST z o) -> s -> ST z o
unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}
instance Functor (S z s) where
fmap :: (a -> b) -> S z s a -> S z s b
fmap a -> b
f (S forall o. (a -> s -> ST z o) -> s -> ST z o
g) = (forall o. (b -> s -> ST z o) -> s -> ST z o) -> S z s b
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\b -> s -> ST z o
k -> (a -> s -> ST z o) -> s -> ST z o
forall o. (a -> s -> ST z o) -> s -> ST z o
g (b -> s -> ST z o
k (b -> s -> ST z o) -> (a -> b) -> a -> s -> ST z o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
instance Monad (S z s) where
return :: a -> S z s a
return = a -> S z s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
S forall o. (a -> s -> ST z o) -> s -> ST z o
g >>= :: S z s a -> (a -> S z s b) -> S z s b
>>= a -> S z s b
f = (forall o. (b -> s -> ST z o) -> s -> ST z o) -> S z s b
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\b -> s -> ST z o
k -> (a -> s -> ST z o) -> s -> ST z o
forall o. (a -> s -> ST z o) -> s -> ST z o
g (\a
a -> S z s b -> (b -> s -> ST z o) -> s -> ST z o
forall z s a.
S z s a -> forall o. (a -> s -> ST z o) -> s -> ST z o
unS (a -> S z s b
f a
a) b -> s -> ST z o
k))
instance Applicative (S z s) where
pure :: a -> S z s a
pure a
a = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k -> a -> s -> ST z o
k a
a)
<*> :: S z s (a -> b) -> S z s a -> S z s b
(<*>) = S z s (a -> b) -> S z s a -> S z s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
gets :: (s -> a) -> S z s a
gets :: (s -> a) -> S z s a
gets s -> a
f = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k s
s -> a -> s -> ST z o
k (s -> a
f s
s) s
s)
modify :: (s -> s) -> S z s ()
modify :: (s -> s) -> S z s ()
modify s -> s
f = (forall o. (() -> s -> ST z o) -> s -> ST z o) -> S z s ()
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\() -> s -> ST z o
k -> () -> s -> ST z o
k () (s -> ST z o) -> (s -> s) -> s -> ST z o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
f)
evalS :: S z s a -> s -> ST z a
evalS :: S z s a -> s -> ST z a
evalS (S forall o. (a -> s -> ST z o) -> s -> ST z o
g) = (a -> s -> ST z a) -> s -> ST z a
forall o. (a -> s -> ST z o) -> s -> ST z o
g ((a -> ST z a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ST z a) -> (s -> a) -> s -> ST z a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((s -> a) -> s -> ST z a) -> (a -> s -> a) -> a -> s -> ST z a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> s -> a
forall a b. a -> b -> a
const)
st :: ST z a -> S z s a
st :: ST z a -> S z s a
st ST z a
m = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k s
s-> do
a
a <- ST z a
m
a -> s -> ST z o
k a
a s
s)
store :: (MArray (A z) a (ST z))
=> (s -> Arr z a) -> Int -> a -> S z s ()
store :: (s -> Arr z a) -> Node -> a -> S z s ()
store s -> Arr z a
f Node
i a
x = do
Arr z a
a <- (s -> Arr z a) -> S z s (Arr z a)
forall s a z. (s -> a) -> S z s a
gets s -> Arr z a
f
ST z () -> S z s ()
forall z a s. ST z a -> S z s a
st ((Arr z a
aArr z a -> a -> Node -> ST z ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=a
x) Node
i)
fetch :: (MArray (A z) a (ST z))
=> (s -> Arr z a) -> Int -> S z s a
fetch :: (s -> Arr z a) -> Node -> S z s a
fetch s -> Arr z a
f Node
i = do
Arr z a
a <- (s -> Arr z a) -> S z s (Arr z a)
forall s a z. (s -> a) -> S z s a
gets s -> Arr z a
f
ST z a -> S z s a
forall z a s. ST z a -> S z s a
st (Arr z a
aArr z a -> Node -> ST z a
forall s a. MArray (A s) a (ST s) => A s Node a -> Node -> ST s a
!:Node
i)
second :: (b -> c) -> (a, b) -> (a, c)
second :: (b -> c) -> (a, b) -> (a, c)
second b -> c
f (a
a, b
b) = (a
a, b -> c
f b
b)