```{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Strict #-}

{- |
Module      :  GHC.CmmToAsm.CFG.Dominators
Copyright   :  (c) Matt Morrow 2009
Maintainer  :  <klebinger.andreas@gmx.at>
Stability   :  stable
Portability :  portable

The Lengauer-Tarjan graph dominators algorithm.

\[1\] Lengauer, Tarjan,
/A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979.

\[2\] Muchnick,
/Advanced Compiler Design and Implementation/, 1997.

/Interference Graphs for Procedures in Static Single/
/Information Form are Interval Graphs/, 2007.

* Strictness

Unless stated otherwise all exposed functions might fully evaluate their input
but are not guaranteed to do so.

-}

module GHC.CmmToAsm.CFG.Dominators (
Node,Path,Edge
,Graph,Rooted
,idom,ipdom
,domTree,pdomTree
,dom,pdom
,pddfs,rpddfs
,asTree,asGraph
,parents,ancestors
) where

import GHC.Prelude
import Data.Bifunctor
import Data.Tuple (swap)

import Data.Tree
import Data.IntMap(IntMap)
import Data.IntSet(IntSet)
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS

import Data.Array.ST
import Data.Array.Base
(unsafeNewArray_

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

type Node       = Int
type Path       = [Node]
type Edge       = (Node,Node)
type Graph      = IntMap IntSet
type Rooted     = (Node, Graph)

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

-- | /Dominators/.
-- Complexity as for @idom@
dom :: Rooted -> [(Node, Path)]
dom :: Rooted -> [(Int, Path)]
dom = Tree Int -> [(Int, Path)]
forall a. Tree a -> [(a, [a])]
ancestors (Tree Int -> [(Int, Path)])
-> (Rooted -> Tree Int) -> Rooted -> [(Int, Path)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Int
domTree

-- | /Post-dominators/.
-- Complexity as for @idom@.
pdom :: Rooted -> [(Node, Path)]
pdom :: Rooted -> [(Int, Path)]
pdom = Tree Int -> [(Int, Path)]
forall a. Tree a -> [(a, [a])]
ancestors (Tree Int -> [(Int, Path)])
-> (Rooted -> Tree Int) -> Rooted -> [(Int, Path)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Int
pdomTree

-- | /Dominator tree/.
-- Complexity as for @idom@.
domTree :: Rooted -> Tree Node
domTree :: Rooted -> Tree Int
domTree a :: Rooted
a@(Int
r,Graph
_) =
let is :: [(Int, Int)]
is = ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
r)(Int -> Bool) -> ((Int, Int) -> Int) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int, Int) -> Int
forall a b. (a, b) -> a
fst) (Rooted -> [(Int, Int)]
idom Rooted
a)
tg :: Graph
tg = [(Int, Int)] -> Graph
fromEdges (((Int, Int) -> (Int, Int)) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> (Int, Int)
forall a b. (a, b) -> (b, a)
swap [(Int, Int)]
is)
in Rooted -> Tree Int
asTree (Int
r,Graph
tg)

-- | /Post-dominator tree/.
-- Complexity as for @idom@.
pdomTree :: Rooted -> Tree Node
pdomTree :: Rooted -> Tree Int
pdomTree a :: Rooted
a@(Int
r,Graph
_) =
let is :: [(Int, Int)]
is = ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
r)(Int -> Bool) -> ((Int, Int) -> Int) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int, Int) -> Int
forall a b. (a, b) -> a
fst) (Rooted -> [(Int, Int)]
ipdom Rooted
a)
tg :: Graph
tg = [(Int, Int)] -> Graph
fromEdges (((Int, Int) -> (Int, Int)) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> (Int, Int)
forall a b. (a, b) -> (b, a)
swap [(Int, Int)]
is)
in Rooted -> Tree Int
asTree (Int
r,Graph
tg)

-- | /Immediate dominators/.
-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is
-- \"a functional inverse of Ackermann's function\".
--
-- This Complexity bound assumes /O(1)/ indexing. Since we're
-- using @IntMap@, it has an additional /lg |V|/ factor
-- somewhere in there. I'm not sure where.
idom :: Rooted -> [(Node,Node)]
idom :: Rooted -> [(Int, Int)]
idom Rooted
rg = (forall s. ST s [(Int, Int)]) -> [(Int, Int)]
forall a. (forall s. ST s a) -> a
runST (S s (Env s) [(Int, Int)] -> Env s -> ST s [(Int, Int)]
forall z s a. S z s a -> s -> ST z a
evalS S s (Env s) [(Int, Int)]
forall s. Dom s [(Int, Int)]
idomM (Env s -> ST s [(Int, Int)]) -> ST s (Env s) -> ST s [(Int, Int)]
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))

-- | /Immediate post-dominators/.
-- Complexity as for @idom@.
ipdom :: Rooted -> [(Node,Node)]
ipdom :: Rooted -> [(Int, Int)]
ipdom Rooted
rg = (forall s. ST s [(Int, Int)]) -> [(Int, Int)]
forall a. (forall s. ST s a) -> a
runST (S s (Env s) [(Int, Int)] -> Env s -> ST s [(Int, Int)]
forall z s a. S z s a -> s -> ST z a
evalS S s (Env s) [(Int, Int)]
forall s. Dom s [(Int, Int)]
idomM (Env s -> ST s [(Int, Int)]) -> ST s (Env s) -> ST s [(Int, Int)]
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)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Graph -> Graph
predG Rooted
rg)))

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

-- | /Post-dominated depth-first search/.
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

-- | /Reverse post-dominated depth-first search/.
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 Int -> [Path]
forall a. Tree a -> [[a]]
levels (Tree Int -> [Path]) -> (Rooted -> Tree Int) -> Rooted -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Int
pdomTree

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

type Dom s a = S s (Env s) a
type NodeSet    = IntSet
type NodeMap a  = IntMap a
data Env s = Env
{forall s. Env s -> Graph
succE      :: !Graph
,forall s. Env s -> Graph
predE      :: !Graph
,forall s. Env s -> Graph
bucketE    :: !Graph
,forall s. Env s -> Int
dfsE       :: {-# UNPACK #-}!Int
,forall s. Env s -> Int
zeroE      :: {-# UNPACK #-}!Node
,forall s. Env s -> Int
rootE      :: {-# UNPACK #-}!Node
,forall s. Env s -> Arr s Int
labelE     :: {-# UNPACK #-}!(Arr s Node)
,forall s. Env s -> Arr s Int
parentE    :: {-# UNPACK #-}!(Arr s Node)
,forall s. Env s -> Arr s Int
ancestorE  :: {-# UNPACK #-}!(Arr s Node)
,forall s. Env s -> Arr s Int
childE     :: {-# UNPACK #-}!(Arr s Node)
,forall s. Env s -> Arr s Int
ndfsE      :: {-# UNPACK #-}!(Arr s Node)
,forall s. Env s -> Arr s Int
dfnE       :: {-# UNPACK #-}!(Arr s Int)
,forall s. Env s -> Arr s Int
sdnoE      :: {-# UNPACK #-}!(Arr s Int)
,forall s. Env s -> Arr s Int
sizeE      :: {-# UNPACK #-}!(Arr s Int)
,forall s. Env s -> Arr s Int
domE       :: {-# UNPACK #-}!(Arr s Node)
,forall s. Env s -> Arr s Int
rnE        :: {-# UNPACK #-}!(Arr s Node)}

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

idomM :: Dom s [(Node,Node)]
idomM :: forall s. Dom s [(Int, Int)]
idomM = do
Int -> Dom s ()
forall s. Int -> Dom s ()
dfsDom (Int -> Dom s ()) -> S s (Env s) Int -> Dom s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< S s (Env s) Int
forall s. Dom s Int
rootM
Int
n <- (Env s -> Int) -> S s (Env s) Int
forall s a z. (s -> a) -> S z s a
gets Env s -> Int
forall s. Env s -> Int
dfsE
Path -> (Int -> Dom s ()) -> Dom s ()
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
n,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1..Int
1] (\Int
i-> do
Int
w <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
ndfsM Int
i
Path
ps <- Int -> Dom s Path
forall s. Int -> Dom s Path
predsM Int
w
Path -> (Int -> Dom s ()) -> Dom s ()
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ Path
ps (\Int
v-> do
Int
sw <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sdnoM Int
w
Int
u <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
eval Int
v
Int
su <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sdnoM Int
u
Bool -> Dom s () -> Dom s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
su Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sw)
((Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
sdnoE Int
w Int
su))
Int
z <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
ndfsM (Int -> S s (Env s) Int) -> S s (Env s) Int -> S s (Env s) Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sdnoM Int
w
(Env s -> Env s) -> Dom s ()
forall s z. (s -> s) -> S z s ()
modify(\Env s
e->Env s
(w`IS.insert`)
z (bucketE e)})
Int
pw <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
parentM Int
w
Int -> Int -> Dom s ()
forall s. Int -> Int -> Dom s ()
pw Int
w
Path
bps <- Int -> Dom s Path
forall s. Int -> Dom s Path
bucketM Int
pw
Path -> (Int -> Dom s ()) -> Dom s ()
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ Path
bps (\Int
v-> do
Int
u <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
eval Int
v
Int
su <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sdnoM Int
u
Int
sv <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sdnoM Int
v
let dv :: Int
dv = case Int
su Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sv of
Bool
True-> Int
u
Bool
False-> Int
pw
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
domE Int
v Int
dv))
Path -> (Int -> Dom s ()) -> Dom s ()
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] (\Int
i-> do
Int
w <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
ndfsM Int
i
Int
j <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sdnoM Int
w
Int
z <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
ndfsM Int
j
Int
dw <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
domM Int
w
Bool -> Dom s () -> Dom s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
dw Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
z)
(do Int
ddw <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
domM Int
dw
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
domE Int
w Int
ddw))
Dom s [(Int, Int)]
forall s. Dom s [(Int, Int)]
fromEnv

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

eval :: Node -> Dom s Node
eval :: forall s. Int -> Dom s Int
eval Int
v = do
Int
n0 <- Dom s Int
forall s. Dom s Int
zeroM
Int
a  <- Int -> Dom s Int
forall s. Int -> Dom s Int
ancestorM Int
v
case Int
aInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
n0 of
Bool
True-> Int -> Dom s Int
forall s. Int -> Dom s Int
labelM Int
v
Bool
False-> do
Int -> Dom s ()
forall s. Int -> Dom s ()
compress Int
v
Int
a   <- Int -> Dom s Int
forall s. Int -> Dom s Int
ancestorM Int
v
Int
l   <- Int -> Dom s Int
forall s. Int -> Dom s Int
labelM Int
v
Int
la  <- Int -> Dom s Int
forall s. Int -> Dom s Int
labelM Int
a
Int
sl  <- Int -> Dom s Int
forall s. Int -> Dom s Int
sdnoM Int
l
Int
sla <- Int -> Dom s Int
forall s. Int -> Dom s Int
sdnoM Int
la
case Int
sl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
sla of
Bool
True-> Int -> Dom s Int
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
l
Bool
False-> Int -> Dom s Int
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
la

compress :: Node -> Dom s ()
compress :: forall s. Int -> Dom s ()
compress Int
v = do
Int
n0  <- Dom s Int
forall s. Dom s Int
zeroM
Int
a   <- Int -> Dom s Int
forall s. Int -> Dom s Int
ancestorM Int
v
Int
aa  <- Int -> Dom s Int
forall s. Int -> Dom s Int
ancestorM Int
a
Bool -> Dom s () -> Dom s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
aa Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n0) (do
Int -> Dom s ()
forall s. Int -> Dom s ()
compress Int
a
Int
a   <- Int -> Dom s Int
forall s. Int -> Dom s Int
ancestorM Int
v
Int
aa  <- Int -> Dom s Int
forall s. Int -> Dom s Int
ancestorM Int
a
Int
l   <- Int -> Dom s Int
forall s. Int -> Dom s Int
labelM Int
v
Int
la  <- Int -> Dom s Int
forall s. Int -> Dom s Int
labelM Int
a
Int
sl  <- Int -> Dom s Int
forall s. Int -> Dom s Int
sdnoM Int
l
Int
sla <- Int -> Dom s Int
forall s. Int -> Dom s Int
sdnoM Int
la
Bool -> Dom s () -> Dom s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sla Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sl)
((Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
labelE Int
v Int
la)
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
ancestorE Int
v Int
aa)

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

link :: Node -> Node -> Dom s ()
link :: forall s. Int -> Int -> Dom s ()
v Int
w = do
Int
n0  <- Dom s Int
forall s. Dom s Int
zeroM
Int
lw  <- Int -> Dom s Int
forall s. Int -> Dom s Int
labelM Int
w
Int
slw <- Int -> Dom s Int
forall s. Int -> Dom s Int
sdnoM Int
lw
let balance :: Int -> Dom s Int
balance Int
s = do
Int
c   <- Int -> Dom s Int
forall s. Int -> Dom s Int
childM Int
s
Int
lc  <- Int -> Dom s Int
forall s. Int -> Dom s Int
labelM Int
c
Int
slc <- Int -> Dom s Int
forall s. Int -> Dom s Int
sdnoM Int
lc
case Int
slw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
slc of
Bool
False-> Int -> Dom s Int
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
s
Bool
True-> do
Int
zs  <- Int -> Dom s Int
forall s. Int -> Dom s Int
sizeM Int
s
Int
zc  <- Int -> Dom s Int
forall s. Int -> Dom s Int
sizeM Int
c
Int
cc  <- Int -> Dom s Int
forall s. Int -> Dom s Int
childM Int
c
Int
zcc <- Int -> Dom s Int
forall s. Int -> Dom s Int
sizeM Int
cc
case Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
zc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
zsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
zcc of
Bool
True-> do
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
ancestorE Int
c Int
s
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
childE Int
s Int
cc
Int -> Dom s Int
balance Int
s
Bool
False-> do
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
sizeE Int
c Int
zs
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
ancestorE Int
s Int
c
Int -> Dom s Int
balance Int
c
Int
s   <- Int -> Dom s Int
balance Int
w
Int
lw  <- Int -> Dom s Int
forall s. Int -> Dom s Int
labelM Int
w
Int
zw  <- Int -> Dom s Int
forall s. Int -> Dom s Int
sizeM Int
w
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
labelE Int
s Int
lw
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
sizeE Int
v (Int -> Dom s ()) -> (Int -> Int) -> Int -> Dom s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
zw) (Int -> Dom s ()) -> Dom s Int -> Dom s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Dom s Int
forall s. Int -> Dom s Int
sizeM Int
v
let follow :: Int -> Dom s ()
s =
Bool -> Dom s () -> Dom s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n0) (do
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
ancestorE Int
s Int
v
Int -> Dom s ()
follow (Int -> Dom s ()) -> Dom s Int -> Dom s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Dom s Int
forall s. Int -> Dom s Int
childM Int
s)
Int
zv  <- Int -> Dom s Int
forall s. Int -> Dom s Int
sizeM Int
v
Int -> Dom s ()
follow (Int -> Dom s ()) -> Dom s Int -> Dom s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Int
zv Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
zw of
Bool
False-> Int -> Dom s Int
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
s
Bool
True-> do
Int
cv <- Int -> Dom s Int
forall s. Int -> Dom s Int
childM Int
v
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
childE Int
v Int
s
Int -> Dom s Int
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
cv

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

dfsDom :: Node -> Dom s ()
dfsDom :: forall s. Int -> Dom s ()
dfsDom Int
i = do
()
_   <- Int -> Dom s ()
forall s. Int -> Dom s ()
go Int
i
Int
n0  <- Dom s Int
forall s. Dom s Int
zeroM
Int
r   <- Dom s Int
forall s. Dom s Int
rootM
(Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
parentE Int
r Int
n0
where go :: Int -> S s (Env s) ()
go Int
i = do
Int
n <- Dom s Int
forall s. Dom s Int
nextM
(Env s -> Arr s Int) -> Int -> Int -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
dfnE   Int
i Int
n
(Env s -> Arr s Int) -> Int -> Int -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
sdnoE  Int
i Int
n
(Env s -> Arr s Int) -> Int -> Int -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
ndfsE  Int
n Int
i
(Env s -> Arr s Int) -> Int -> Int -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
labelE Int
i Int
i
Path
ss <- Int -> Dom s Path
forall s. Int -> Dom s Path
succsM Int
i
Path -> (Int -> S s (Env s) ()) -> S s (Env s) ()
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ Path
ss (\Int
j-> do
Int
s <- Int -> Dom s Int
forall s. Int -> Dom s Int
sdnoM Int
j
case Int
sInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 of
Bool
False-> () -> S s (Env s) ()
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return()
Bool
True-> do
(Env s -> Arr s Int) -> Int -> Int -> S s (Env s) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
parentE Int
j Int
i
Int -> S s (Env s) ()
go Int
j)

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

initEnv :: Rooted -> ST s (Env s)
initEnv :: forall s. Rooted -> ST s (Env s)
initEnv (Int
r0,Graph
g0) = do
-- Graph renumbered to indices from 1 to |V|
let (Graph
g,NodeMap Int
rnmap) = Int -> Graph -> (Graph, NodeMap Int)
renum Int
1 Graph
g0
pred :: Graph
pred      = Graph -> Graph
predG Graph
g -- reverse graph
root :: Int
root      = NodeMap Int
rnmap NodeMap Int -> Int -> Int
forall a. IntMap a -> Int -> a
IM.! Int
r0 -- renamed root
n :: Int
n         = Graph -> Int
forall a. IntMap a -> Int
IM.size Graph
g
ns :: Path
ns        = [Int
0..Int
n]
m :: Int
m         = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1

let bucket :: Graph
bucket = [(Int, IntSet)] -> Graph
forall a. [(Int, a)] -> IntMap a
IM.fromList
(Path -> [IntSet] -> [(Int, 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 Int
rna <- Int -> ST s (Arr s Int)
forall s. Int -> ST s (Arr s Int)
newI Int
m
Arr s Int -> [(Int, Int)] -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> [(Int, a)] -> ST s ()
writes Arr s Int
rna (((Int, Int) -> (Int, Int)) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> (Int, Int)
forall a b. (a, b) -> (b, a)
swap
(NodeMap Int -> [(Int, Int)]
forall a. IntMap a -> [(Int, a)]
IM.toList NodeMap Int
rnmap))

Arr s Int
doms      <- Int -> ST s (Arr s Int)
forall s. Int -> ST s (Arr s Int)
newI Int
m
Arr s Int
sdno      <- Int -> ST s (Arr s Int)
forall s. Int -> ST s (Arr s Int)
newI Int
m
Arr s Int
size      <- Int -> ST s (Arr s Int)
forall s. Int -> ST s (Arr s Int)
newI Int
m
Arr s Int
parent    <- Int -> ST s (Arr s Int)
forall s. Int -> ST s (Arr s Int)
newI Int
m
Arr s Int
ancestor  <- Int -> ST s (Arr s Int)
forall s. Int -> ST s (Arr s Int)
newI Int
m
Arr s Int
child     <- Int -> ST s (Arr s Int)
forall s. Int -> ST s (Arr s Int)
newI Int
m
Arr s Int
label     <- Int -> ST s (Arr s Int)
forall s. Int -> ST s (Arr s Int)
newI Int
m
Arr s Int
ndfs      <- Int -> ST s (Arr s Int)
forall s. Int -> ST s (Arr s Int)
newI Int
m
Arr s Int
dfn       <- Int -> ST s (Arr s Int)
forall s. Int -> ST s (Arr s Int)
newI Int
m

-- Initialize all arrays
Path -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
n] (Arr s Int
domsArr s Int -> Int -> Int -> ST s ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0)
Path -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
n] (Arr s Int
sdnoArr s Int -> Int -> Int -> ST s ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0)
Path -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] (Arr s Int
sizeArr s Int -> Int -> Int -> ST s ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
1)
Path -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
n] (Arr s Int
ancestorArr s Int -> Int -> Int -> ST s ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0)
Path -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
n] (Arr s Int
childArr s Int -> Int -> Int -> ST s ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0)

(Arr s Int
domsArr s Int -> Int -> Int -> ST s ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
root) Int
root
(Arr s Int
sizeArr s Int -> Int -> Int -> ST s ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0) Int
0
(Arr s Int
labelArr s Int -> Int -> Int -> ST s ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0) Int
0

Env s -> ST s (Env s)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
{rnE :: Arr s Int
rnE        = Arr s Int
rna
,dfsE :: Int
dfsE       = Int
0
,zeroE :: Int
zeroE      = Int
0
,rootE :: Int
rootE      = Int
root
,labelE :: Arr s Int
labelE     = Arr s Int
label
,parentE :: Arr s Int
parentE    = Arr s Int
parent
,ancestorE :: Arr s Int
ancestorE  = Arr s Int
ancestor
,childE :: Arr s Int
childE     = Arr s Int
child
,ndfsE :: Arr s Int
ndfsE      = Arr s Int
ndfs
,dfnE :: Arr s Int
dfnE       = Arr s Int
dfn
,sdnoE :: Arr s Int
sdnoE      = Arr s Int
sdno
,sizeE :: Arr s Int
sizeE      = Arr s Int
size
,succE :: Graph
succE      = Graph
g
,predE :: Graph
predE      = Graph
pred
,bucketE :: Graph
bucketE    = Graph
bucket
,domE :: Arr s Int
domE       = Arr s Int
doms})

fromEnv :: Dom s [(Node,Node)]
fromEnv :: forall s. Dom s [(Int, Int)]
fromEnv = do
Arr s Int
dom   <- (Env s -> Arr s Int) -> S s (Env s) (Arr s Int)
forall s a z. (s -> a) -> S z s a
gets Env s -> Arr s Int
forall s. Env s -> Arr s Int
domE
Arr s Int
rn    <- (Env s -> Arr s Int) -> S s (Env s) (Arr s Int)
forall s a z. (s -> a) -> S z s a
gets Env s -> Arr s Int
forall s. Env s -> Arr s Int
rnE
-- r     <- gets rootE
(Int
_,Int
n) <- ST s (Int, Int) -> S s (Env s) (Int, Int)
forall z a s. ST z a -> S z s a
st (Arr s Int -> ST s (Int, Int)
forall i. Ix i => STUArray s i Int -> ST s (i, i)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds Arr s Int
dom)
Path -> (Int -> S s (Env s) (Int, Int)) -> Dom s [(Int, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m (t b)
forM [Int
1..Int
n] (\Int
i-> do
Int
j <- ST s Int -> S s (Env s) Int
forall z a s. ST z a -> S z s a
st(Arr s Int
rnArr s Int -> Int -> ST s Int
forall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!:Int
i)
Int
d <- ST s Int -> S s (Env s) Int
forall z a s. ST z a -> S z s a
st(Arr s Int
domArr s Int -> Int -> ST s Int
forall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!:Int
i)
Int
k <- ST s Int -> S s (Env s) Int
forall z a s. ST z a -> S z s a
st(Arr s Int
rnArr s Int -> Int -> ST s Int
forall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!:Int
d)
(Int, Int) -> S s (Env s) (Int, Int)
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
j,Int
k))

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

zeroM :: Dom s Node
zeroM :: forall s. Dom s Int
zeroM = (Env s -> Int) -> S s (Env s) Int
forall s a z. (s -> a) -> S z s a
gets Env s -> Int
forall s. Env s -> Int
zeroE
domM :: Node -> Dom s Node
domM :: forall s. Int -> Dom s Int
domM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
domE
rootM :: Dom s Node
rootM :: forall s. Dom s Int
rootM = (Env s -> Int) -> S s (Env s) Int
forall s a z. (s -> a) -> S z s a
gets Env s -> Int
forall s. Env s -> Int
rootE
succsM :: Node -> Dom s [Node]
succsM :: forall s. Int -> Dom s Path
succsM Int
i = (Env s -> Path) -> S s (Env 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 -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
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 :: forall s. Int -> Dom s Path
predsM Int
i = (Env s -> Path) -> S s (Env 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 -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
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 :: forall s. Int -> Dom s Path
bucketM Int
i = (Env s -> Path) -> S s (Env 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 -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
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 :: forall s. Int -> Dom s Int
sizeM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
sizeE
sdnoM :: Node -> Dom s Int
sdnoM :: forall s. Int -> Dom s Int
sdnoM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
sdnoE
-- dfnM :: Node -> Dom s Int
-- dfnM = fetch dfnE
ndfsM :: Int -> Dom s Node
ndfsM :: forall s. Int -> Dom s Int
ndfsM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
ndfsE
childM :: Node -> Dom s Node
childM :: forall s. Int -> Dom s Int
childM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
childE
ancestorM :: Node -> Dom s Node
ancestorM :: forall s. Int -> Dom s Int
ancestorM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
ancestorE
parentM :: Node -> Dom s Node
parentM :: forall s. Int -> Dom s Int
parentM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
parentE
labelM :: Node -> Dom s Node
labelM :: forall s. Int -> Dom s Int
labelM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
labelE
nextM :: Dom s Int
nextM :: forall s. Dom s Int
nextM = do
Int
n <- (Env s -> Int) -> Dom s Int
forall s a z. (s -> a) -> S z s a
gets Env s -> Int
forall s. Env s -> Int
dfsE
let n' :: Int
n' = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
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=n'})
Int -> Dom s Int
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'

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

type A = STUArray
type Arr s a = A s Int a

infixl 9 !:
infixr 2 .=

-- | arr .= x idx => write x to index
(.=) :: (MArray (A s) a (ST s))
=> Arr s a -> a -> Int -> ST s ()
(Arr s a
v .= :: forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.= a
x) Int
i = Arr s a -> Int -> a -> ST s ()
forall i. Ix i => STUArray s i a -> Int -> a -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite Arr s a
v Int
i a
x

(!:) :: (MArray (A s) a (ST s))
=> A s Int a -> Int -> ST s a
A s Int a
a !: :: forall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!: Int
i = do
a
o <- A s Int a -> Int -> ST s a
forall i. Ix i => STUArray s i a -> Int -> ST s a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
a Int
i
a -> ST s a
forall a. 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 :: forall s a. MArray (A s) a (ST s) => Int -> ST s (Arr s a)
new Int
n = (Int, Int) -> ST s (STUArray s Int a)
forall i. Ix i => (i, i) -> ST s (STUArray s i a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
unsafeNewArray_ (Int
0,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

newI :: Int -> ST s (Arr s Int)
newI :: forall s. Int -> ST s (Arr s Int)
newI = Int -> ST s (Arr s Int)
forall s a. MArray (A s) a (ST s) => Int -> ST s (Arr s a)
new

writes :: (MArray (A s) a (ST s))
=> Arr s a -> [(Int,a)] -> ST s ()
writes :: forall s a.
MArray (A s) a (ST s) =>
Arr s a -> [(Int, a)] -> ST s ()
writes Arr s a
a [(Int, a)]
xs = [(Int, a)] -> ((Int, a) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [(Int, a)]
xs (\(Int
i,a
x) -> (Arr s a
aArr s a -> a -> Int -> ST s ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=a
x) Int
i)

(!) :: Monoid a => IntMap a -> Int -> a
! :: forall a. Monoid a => IntMap a -> Int -> a
(!) IntMap a
g Int
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 (Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
n IntMap a
g)

fromAdj :: [(Node, [Node])] -> Graph
fromAdj :: [(Int, Path)] -> Graph
fromAdj = [(Int, IntSet)] -> Graph
forall a. [(Int, a)] -> IntMap a
IM.fromList ([(Int, IntSet)] -> Graph)
-> ([(Int, Path)] -> [(Int, IntSet)]) -> [(Int, Path)] -> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Path) -> (Int, IntSet)) -> [(Int, Path)] -> [(Int, IntSet)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Path -> IntSet) -> (Int, Path) -> (Int, IntSet)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Path -> IntSet
IS.fromList)

fromEdges :: [Edge] -> Graph
fromEdges :: [(Int, Int)] -> Graph
fromEdges = (IntSet -> IntSet -> IntSet)
-> ((Int, Int) -> Int)
-> ((Int, Int) -> IntSet)
-> [(Int, Int)]
-> Graph
forall c a.
(c -> c -> c) -> (a -> Int) -> (a -> c) -> [a] -> IntMap c
collectI IntSet -> IntSet -> IntSet
IS.union (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int -> IntSet
IS.singleton (Int -> IntSet) -> ((Int, Int) -> Int) -> (Int, Int) -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd)

toAdj :: Graph -> [(Node, [Node])]
toAdj :: Graph -> [(Int, Path)]
toAdj = ((Int, IntSet) -> (Int, Path)) -> [(Int, IntSet)] -> [(Int, Path)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IntSet -> Path) -> (Int, IntSet) -> (Int, Path)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second IntSet -> Path
IS.toList) ([(Int, IntSet)] -> [(Int, Path)])
-> (Graph -> [(Int, IntSet)]) -> Graph -> [(Int, Path)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [(Int, IntSet)]
forall a. IntMap a -> [(Int, a)]
IM.toList

toEdges :: Graph -> [Edge]
toEdges :: Graph -> [(Int, Int)]
toEdges = ((Int, Path) -> [(Int, Int)]) -> [(Int, Path)] -> [(Int, Int)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Int -> Path -> [(Int, Int)]) -> (Int, Path) -> [(Int, Int)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Int -> (Int, Int)) -> Path -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> (Int, Int)) -> Path -> [(Int, Int)])
-> (Int -> Int -> (Int, Int)) -> Int -> Path -> [(Int, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,))) ([(Int, Path)] -> [(Int, Int)])
-> (Graph -> [(Int, Path)]) -> Graph -> [(Int, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [(Int, Path)]

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 a b. (a -> b) -> IntMap a -> IntMap b
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 = ((Int -> IntSet -> Graph -> Graph) -> Graph -> Graph -> Graph)
-> Graph -> (Int -> IntSet -> Graph -> Graph) -> Graph -> Graph
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> IntSet -> Graph -> Graph) -> Graph -> Graph -> Graph
forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey Graph
forall a. Monoid a => a
mempty (\Int
i IntSet
a Graph
m ->
(Graph -> Int -> Graph) -> Graph -> Path -> Graph
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Graph
m Int
p -> (IntSet -> IntSet -> IntSet) -> Int -> IntSet -> Graph -> Graph
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
forall a. Monoid a => a -> a -> a
mappend Int
p
(Int -> IntSet
IS.singleton Int
i) Graph
m)
Graph
m
(IntSet -> Path
IS.toList IntSet
a))

pruneReach :: Rooted -> Rooted
pruneReach :: Rooted -> Rooted
pruneReach (Int
r,Graph
g) = (Int
r,Graph
g2)
where is :: IntSet
is = (Int -> IntSet) -> Int -> 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) -> (Int -> Maybe IntSet) -> Int -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Graph -> Maybe IntSet) -> Graph -> Int -> Maybe IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Graph -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup Graph
g) (Int -> IntSet) -> Int -> IntSet
forall a b. (a -> b) -> a -> b
\$ Int
r
g2 :: Graph
g2 = [(Int, IntSet)] -> Graph
forall a. [(Int, a)] -> IntMap a
IM.fromList
([(Int, IntSet)] -> Graph)
-> (Graph -> [(Int, IntSet)]) -> Graph -> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, IntSet) -> (Int, IntSet))
-> [(Int, IntSet)] -> [(Int, IntSet)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IntSet -> IntSet) -> (Int, IntSet) -> (Int, IntSet)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Int -> Bool) -> IntSet -> IntSet
IS.filter (Int -> IntSet -> Bool
`IS.member`IntSet
is)))
([(Int, IntSet)] -> [(Int, IntSet)])
-> (Graph -> [(Int, IntSet)]) -> Graph -> [(Int, IntSet)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, IntSet) -> Bool) -> [(Int, IntSet)] -> [(Int, IntSet)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> IntSet -> Bool
`IS.member`IntSet
is) (Int -> Bool) -> ((Int, IntSet) -> Int) -> (Int, IntSet) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, IntSet) -> Int
forall a b. (a, b) -> a
fst)
([(Int, IntSet)] -> [(Int, IntSet)])
-> (Graph -> [(Int, IntSet)]) -> Graph -> [(Int, IntSet)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [(Int, IntSet)]
forall a. IntMap a -> [(Int, a)]
IM.toList (Graph -> Graph) -> Graph -> Graph
forall a b. (a -> b) -> a -> b
\$ Graph
g

tip :: Tree a -> (a, [Tree a])
tip :: forall a. Tree a -> (a, [Tree a])
tip (Node a
a [Tree a]
ts) = (a
a, [Tree a]
ts)

parents :: Tree a -> [(a, a)]
parents :: forall a. Tree a -> [(a, a)]
parents (Node a
i [Tree a]
xs) = a -> [Tree a] -> [(a, a)]
forall {f :: * -> *} {b} {b}.
Functor f =>
b -> f (Tree b) -> f (b, b)
p a
i [Tree a]
xs
[(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ (Tree a -> [(a, a)]) -> [Tree 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 [Tree a]
xs
where p :: b -> f (Tree b) -> f (b, b)
p b
i = (Tree b -> (b, b)) -> f (Tree b) -> f (b, b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> b -> (b, b)) -> b -> b -> (b, b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) b
i (b -> (b, b)) -> (Tree b -> b) -> Tree b -> (b, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree b -> b
forall a. Tree a -> a
rootLabel)

ancestors :: Tree a -> [(a, [a])]
ancestors :: forall a. Tree a -> [(a, [a])]
ancestors = [a] -> Tree a -> [(a, [a])]
forall {b}. [b] -> Tree b -> [(b, [b])]
go []
where go :: [b] -> Tree b -> [(b, [b])]
go [b]
acc (Node b
i [Tree b]
xs)
= let acc' :: [b]
acc' = b
ib -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
acc
in [b] -> [Tree b] -> [(b, [b])]
forall {f :: * -> *} {b} {b}.
Functor f =>
b -> f (Tree b) -> f (b, b)
p [b]
acc' [Tree b]
xs [(b, [b])] -> [(b, [b])] -> [(b, [b])]
forall a. [a] -> [a] -> [a]
++ (Tree b -> [(b, [b])]) -> [Tree b] -> [(b, [b])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([b] -> Tree b -> [(b, [b])]
go [b]
acc') [Tree b]
xs
p :: b -> f (Tree b) -> f (b, b)
p b
is = (Tree b -> (b, b)) -> f (Tree b) -> f (b, b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> b -> (b, b)) -> b -> b -> (b, b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) b
is (b -> (b, b)) -> (Tree b -> b) -> Tree b -> (b, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree b -> b
forall a. Tree a -> a
rootLabel)

asGraph :: Tree Node -> Rooted
asGraph :: Tree Int -> Rooted
asGraph t :: Tree Int
t@(Node Int
a [Tree Int]
_) = let g :: [(Int, Path)]
g = Tree Int -> [(Int, Path)]
forall a. Tree a -> [(a, [a])]
go Tree Int
t in (Int
a, [(Int, Path)] -> Graph
g)
where go :: Tree a -> [(a, [a])]
go (Node a
a [Tree a]
ts) = let as :: [a]
as = (([a], [[Tree a]]) -> [a]
forall a b. (a, b) -> a
fst (([a], [[Tree a]]) -> [a])
-> ([Tree a] -> ([a], [[Tree a]])) -> [Tree a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, [Tree a])] -> ([a], [[Tree a]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(a, [Tree a])] -> ([a], [[Tree a]]))
-> ([Tree a] -> [(a, [Tree a])]) -> [Tree a] -> ([a], [[Tree a]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree a -> (a, [Tree a])) -> [Tree a] -> [(a, [Tree a])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree a -> (a, [Tree a])
forall a. Tree a -> (a, [Tree a])
tip) [Tree a]
ts
in (a
a, [a]
as) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: (Tree a -> [(a, [a])]) -> [Tree a] -> [(a, [a])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [(a, [a])]
go [Tree a]
ts

asTree :: Rooted -> Tree Node
asTree :: Rooted -> Tree Int
asTree (Int
r,Graph
g) = let go :: Int -> Tree Int
go Int
a = Int -> [Tree Int] -> Tree Int
forall a. a -> [Tree a] -> Tree a
Node Int
a ((Int -> Tree Int) -> Path -> [Tree Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Tree Int
go ((IntSet -> Path
IS.toList (IntSet -> Path) -> (Int -> IntSet) -> Int -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntSet
f) Int
a))
f :: Int -> IntSet
f = (Graph
g Graph -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
!)
in Int -> Tree Int
go Int
r

reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
reachable :: (Int -> IntSet) -> Int -> IntSet
reachable Int -> IntSet
f Int
a = IntSet -> Int -> IntSet
go (Int -> IntSet
IS.singleton Int
a) Int
a
where go :: IntSet -> Int -> IntSet
go IntSet
seen Int
a = let s :: IntSet
s = Int -> IntSet
f Int
a
as :: Path
as = IntSet -> Path
IS.toList (IntSet
s IntSet -> IntSet -> IntSet
`IS.difference` IntSet
seen)
in (IntSet -> Int -> IntSet) -> IntSet -> Path -> IntSet
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntSet -> Int -> 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 :: forall c a.
(c -> c -> c) -> (a -> Int) -> (a -> c) -> [a] -> IntMap c
collectI c -> c -> c
(<>) a -> Int
f a -> c
g
= (IntMap c -> a -> IntMap c) -> IntMap c -> [a] -> IntMap c
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\IntMap c
m a
a -> (c -> c -> c) -> Int -> c -> IntMap c -> IntMap c
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith c -> c -> c
(<>)
(a -> Int
f a
a)
(a -> c
g a
a) IntMap c
m) IntMap c
forall a. Monoid a => a
mempty

-- | renum n g: Rename all nodes
--
-- Gives nodes sequential names starting at n.
-- Returns the new graph and a mapping.
-- (renamed, old -> new)
renum :: Int -> Graph -> (Graph, NodeMap Node)
renum :: Int -> Graph -> (Graph, NodeMap Int)
renum Int
from = (\(Int
_,NodeMap Int
m,Graph
g)->(Graph
g,NodeMap Int
m))
((Int, NodeMap Int, Graph) -> (Graph, NodeMap Int))
-> (Graph -> (Int, NodeMap Int, Graph))
-> Graph
-> (Graph, NodeMap Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
-> IntSet
-> (Int, NodeMap Int, Graph)
-> (Int, NodeMap Int, Graph))
-> (Int, NodeMap Int, Graph) -> Graph -> (Int, NodeMap Int, Graph)
forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey
(\Int
i IntSet
ss (!Int
n,!NodeMap Int
env,!Graph
new)->
let (Int
j,Int
n2,NodeMap Int
env2) = Int -> NodeMap Int -> Int -> (Int, Int, NodeMap Int)
go Int
n NodeMap Int
env Int
i
(Int
n3,NodeMap Int
env3,IntSet
ss2) = (Int -> (Int, NodeMap Int, IntSet) -> (Int, NodeMap Int, IntSet))
-> (Int, NodeMap Int, IntSet)
-> IntSet
-> (Int, NodeMap Int, IntSet)
forall b. (Int -> b -> b) -> b -> IntSet -> b
IS.fold
(\Int
k (!Int
n,!NodeMap Int
env,!IntSet
new)->
case Int -> NodeMap Int -> Int -> (Int, Int, NodeMap Int)
go Int
n NodeMap Int
env Int
k of
(Int
l,Int
n2,NodeMap Int
env2)-> (Int
n2,NodeMap Int
env2,Int
l Int -> IntSet -> IntSet
`IS.insert` IntSet
new))
(Int
n2,NodeMap Int
env2,IntSet
forall a. Monoid a => a
mempty) IntSet
ss
new2 :: Graph
new2 = (IntSet -> IntSet -> IntSet) -> Int -> IntSet -> Graph -> Graph
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
IS.union Int
j IntSet
ss2 Graph
new
in (Int
n3,NodeMap Int
env3,Graph
new2)) (Int
from,NodeMap Int
forall a. Monoid a => a
mempty,Graph
forall a. Monoid a => a
mempty)
where go :: Int
-> NodeMap Node
-> Node
-> (Node,Int,NodeMap Node)
go :: Int -> NodeMap Int -> Int -> (Int, Int, NodeMap Int)
go !Int
n !NodeMap Int
env Int
i =
case Int -> NodeMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i NodeMap Int
env of
Just Int
j -> (Int
j,Int
n,NodeMap Int
env)
Maybe Int
Nothing -> (Int
n,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int -> Int -> NodeMap Int -> NodeMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Int
n NodeMap Int
env)

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

-- Nothing better than reinventing the state monad.
newtype S z s a = S {forall z s a.
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}
deriving ((forall a b. (a -> b) -> S z s a -> S z s b)
-> (forall a b. a -> S z s b -> S z s a) -> Functor (S z s)
forall a b. a -> S z s b -> S z s a
forall a b. (a -> b) -> S z s a -> S z s b
forall z s a b. a -> S z s b -> S z s a
forall z s a b. (a -> b) -> S z s a -> S z s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
\$cfmap :: forall z s a b. (a -> b) -> S z s a -> S z s b
fmap :: forall a b. (a -> b) -> S z s a -> S z s b
\$c<\$ :: forall z s a b. a -> S z s b -> S z s a
<\$ :: forall a b. a -> S z s b -> S z s a
Functor)
instance Monad (S z s) where
return :: forall a. a -> S z s a
return = a -> S z s a
forall a. 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 >>= :: forall a b. 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 -> forall o. (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 :: forall a. 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)
<*> :: forall a b. 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
-- get :: S z s s
-- get = S (\k s -> k s s)
gets :: (s -> a) -> S z s a
gets :: forall s a z. (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)
-- set :: s -> S z s ()
-- set s = S (\k _ -> k () s)
modify :: (s -> s) -> S z s ()
modify :: forall s z. (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)
-- runS :: S z s a -> s -> ST z (a, s)
-- runS (S g) = g (\a s -> return (a,s))
evalS :: S z s a -> s -> ST z a
evalS :: forall z s a. 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 a. 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)
-- execS :: S z s a -> s -> ST z s
-- execS (S g) = g ((return .) . flip const)
st :: ST z a -> S z s a
st :: forall z a s. 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 :: forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store s -> Arr z a
f Int
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 -> Int -> ST z ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=a
x) Int
i)
fetch :: (MArray (A z) a (ST z))
=> (s -> Arr z a) -> Int -> S z s a
fetch :: forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch s -> Arr z a
f Int
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 -> Int -> ST z a
forall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!:Int
i)
```