```{-# LANGUAGE BangPatterns #-}
{-# 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 = forall a. Tree a -> [(a, [a])]
ancestors 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 = forall a. Tree a -> [(a, [a])]
ancestors 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 = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=Int
r)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) (Rooted -> [(Int, Int)]
idom Rooted
a)
tg :: Graph
tg = [(Int, Int)] -> Graph
fromEdges (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=Int
r)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) (Rooted -> [(Int, Int)]
ipdom Rooted
a)
tg :: Graph
tg = [(Int, Int)] -> Graph
fromEdges (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 a. (forall s. ST s a) -> a
runST (forall z s a. S z s a -> s -> ST z a
evalS forall s. Dom s [(Int, Int)]
idomM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 a. (forall s. ST s a) -> a
runST (forall z s a. S z s a -> s -> ST z a
evalS forall s. Dom s [(Int, Int)]
idomM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Rooted -> ST s (Env s)
initEnv (Rooted -> Rooted
pruneReach (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 = forall a. [a] -> [a]
reverse 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> [[a]]
levels 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
forall s. Int -> Dom s ()
dfsDom forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Dom s Int
rootM
Int
n <- forall s a z. (s -> a) -> S z s a
gets forall s. Env s -> Int
dfsE
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
n,Int
nforall a. Num a => a -> a -> a
-Int
1..Int
1] (\Int
i-> do
Int
w <- forall s. Int -> Dom s Int
ndfsM Int
i
Path
ps <- forall s. Int -> Dom s Path
predsM Int
w
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ Path
ps (\Int
v-> do
Int
sw <- forall s. Int -> Dom s Int
sdnoM Int
w
Int
u <- forall s. Int -> Dom s Int
eval Int
v
Int
su <- forall s. Int -> Dom s Int
sdnoM Int
u
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
su forall a. Ord a => a -> a -> Bool
< Int
sw)
(forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
sdnoE Int
w Int
su))
Int
z <- forall s. Int -> Dom s Int
ndfsM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Int -> Dom s Int
sdnoM Int
w
forall s z. (s -> s) -> S z s ()
modify(\Env s
e->Env s
e{bucketE :: Graph
bucketE=forall a. (a -> a) -> Int -> IntMap a -> IntMap a
(Int
wInt -> IntSet -> IntSet
`IS.insert`)
Int
z (forall s. Env s -> Graph
bucketE Env s
e)})
Int
pw <- forall s. Int -> Dom s Int
parentM Int
w
forall s. Int -> Int -> Dom s ()
pw Int
w
Path
bps <- forall s. Int -> Dom s Path
bucketM Int
pw
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ Path
bps (\Int
v-> do
Int
u <- forall s. Int -> Dom s Int
eval Int
v
Int
su <- forall s. Int -> Dom s Int
sdnoM Int
u
Int
sv <- forall s. Int -> Dom s Int
sdnoM Int
v
let dv :: Int
dv = case Int
su forall a. Ord a => a -> a -> Bool
< Int
sv of
Bool
True-> Int
u
Bool
False-> Int
pw
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
domE Int
v Int
dv))
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] (\Int
i-> do
Int
w <- forall s. Int -> Dom s Int
ndfsM Int
i
Int
j <- forall s. Int -> Dom s Int
sdnoM Int
w
Int
z <- forall s. Int -> Dom s Int
ndfsM Int
j
Int
dw <- forall s. Int -> Dom s Int
domM Int
w
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
dw forall a. Eq a => a -> a -> Bool
/= Int
z)
(do Int
ddw <- forall s. Int -> Dom s Int
domM Int
dw
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
domE Int
w Int
ddw))
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 <- forall s. Dom s Int
zeroM
Int
a  <- forall s. Int -> Dom s Int
ancestorM Int
v
case Int
aforall a. Eq a => a -> a -> Bool
==Int
n0 of
Bool
True-> forall s. Int -> Dom s Int
labelM Int
v
Bool
False-> do
forall s. Int -> Dom s ()
compress Int
v
Int
a   <- forall s. Int -> Dom s Int
ancestorM Int
v
Int
l   <- forall s. Int -> Dom s Int
labelM Int
v
Int
la  <- forall s. Int -> Dom s Int
labelM Int
a
Int
sl  <- forall s. Int -> Dom s Int
sdnoM Int
l
Int
sla <- forall s. Int -> Dom s Int
sdnoM Int
la
case Int
sl forall a. Ord a => a -> a -> Bool
<= Int
sla of
Bool
True-> forall (m :: * -> *) a. Monad m => a -> m a
return Int
l
Bool
False-> 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  <- forall s. Dom s Int
zeroM
Int
a   <- forall s. Int -> Dom s Int
ancestorM Int
v
Int
aa  <- forall s. Int -> Dom s Int
ancestorM Int
a
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
aa forall a. Eq a => a -> a -> Bool
/= Int
n0) (do
forall s. Int -> Dom s ()
compress Int
a
Int
a   <- forall s. Int -> Dom s Int
ancestorM Int
v
Int
aa  <- forall s. Int -> Dom s Int
ancestorM Int
a
Int
l   <- forall s. Int -> Dom s Int
labelM Int
v
Int
la  <- forall s. Int -> Dom s Int
labelM Int
a
Int
sl  <- forall s. Int -> Dom s Int
sdnoM Int
l
Int
sla <- forall s. Int -> Dom s Int
sdnoM Int
la
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sla forall a. Ord a => a -> a -> Bool
< Int
sl)
(forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
labelE Int
v Int
la)
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store 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  <- forall s. Dom s Int
zeroM
Int
lw  <- forall s. Int -> Dom s Int
labelM Int
w
Int
slw <- forall s. Int -> Dom s Int
sdnoM Int
lw
let balance :: Int -> S s (Env s) Int
balance Int
s = do
Int
c   <- forall s. Int -> Dom s Int
childM Int
s
Int
lc  <- forall s. Int -> Dom s Int
labelM Int
c
Int
slc <- forall s. Int -> Dom s Int
sdnoM Int
lc
case Int
slw forall a. Ord a => a -> a -> Bool
< Int
slc of
Bool
False-> forall (m :: * -> *) a. Monad m => a -> m a
return Int
s
Bool
True-> do
Int
zs  <- forall s. Int -> Dom s Int
sizeM Int
s
Int
zc  <- forall s. Int -> Dom s Int
sizeM Int
c
Int
cc  <- forall s. Int -> Dom s Int
childM Int
c
Int
zcc <- forall s. Int -> Dom s Int
sizeM Int
cc
case Int
2forall a. Num a => a -> a -> a
*Int
zc forall a. Ord a => a -> a -> Bool
<= Int
zsforall a. Num a => a -> a -> a
+Int
zcc of
Bool
True-> do
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
ancestorE Int
c Int
s
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
childE Int
s Int
cc
Int -> S s (Env s) Int
balance Int
s
Bool
False-> do
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
sizeE Int
c Int
zs
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
ancestorE Int
s Int
c
Int -> S s (Env s) Int
balance Int
c
Int
s   <- Int -> S s (Env s) Int
balance Int
w
Int
lw  <- forall s. Int -> Dom s Int
labelM Int
w
Int
zw  <- forall s. Int -> Dom s Int
sizeM Int
w
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
labelE Int
s Int
lw
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
sizeE Int
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Int
zw) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Int -> Dom s Int
sizeM Int
v
let follow :: Int -> Dom s ()
s =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
s forall a. Eq a => a -> a -> Bool
/= Int
n0) (do
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
ancestorE Int
s Int
v
Int -> Dom s ()
follow forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Int -> Dom s Int
childM Int
s)
Int
zv  <- forall s. Int -> Dom s Int
sizeM Int
v
Int -> Dom s ()
follow forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Int
zv forall a. Ord a => a -> a -> Bool
< Int
2forall a. Num a => a -> a -> a
*Int
zw of
Bool
False-> forall (m :: * -> *) a. Monad m => a -> m a
return Int
s
Bool
True-> do
Int
cv <- forall s. Int -> Dom s Int
childM Int
v
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
childE Int
v Int
s
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
()
_   <- forall s. Int -> Dom s ()
go Int
i
Int
n0  <- forall s. Dom s Int
zeroM
Int
r   <- forall s. Dom s Int
rootM
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store 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 <- forall s. Dom s Int
nextM
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
dfnE   Int
i Int
n
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
sdnoE  Int
i Int
n
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
ndfsE  Int
n Int
i
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store forall s. Env s -> Arr s Int
labelE Int
i Int
i
Path
ss <- forall s. Int -> Dom s Path
succsM Int
i
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ Path
ss (\Int
j-> do
Int
s <- forall s. Int -> Dom s Int
sdnoM Int
j
case Int
sforall a. Eq a => a -> a -> Bool
==Int
0 of
Bool
False-> forall (m :: * -> *) a. Monad m => a -> m a
return()
Bool
True-> do
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store 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 forall a. IntMap a -> Int -> a
IM.! Int
r0 -- renamed root
n :: Int
n         = forall a. IntMap a -> Int
IM.size Graph
g
ns :: Path
ns        = [Int
0..Int
n]
m :: Int
m         = Int
nforall a. Num a => a -> a -> a
+Int
1

let bucket :: Graph
bucket = forall a. [(Int, a)] -> IntMap a
IM.fromList
(forall a b. [a] -> [b] -> [(a, b)]
zip Path
ns (forall a. a -> [a]
repeat forall a. Monoid a => a
mempty))

Arr s Int
rna <- forall s. Int -> ST s (Arr s Int)
newI Int
m
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> [(Int, a)] -> ST s ()
writes Arr s Int
rna (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> (b, a)
swap
(forall a. IntMap a -> [(Int, a)]
IM.toList NodeMap Int
rnmap))

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

-- Initialize all arrays
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
n] (Arr s Int
domsforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0)
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
n] (Arr s Int
sdnoforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0)
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] (Arr s Int
sizeforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
1)
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
n] (Arr s Int
ancestorforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0)
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
n] (Arr s Int
childforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0)

(Arr s Int
domsforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
root) Int
root
(Arr s Int
sizeforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0) Int
0
(Arr s Int
labelforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=Int
0) Int
0

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   <- forall s a z. (s -> a) -> S z s a
gets forall s. Env s -> Arr s Int
domE
Arr s Int
rn    <- forall s a z. (s -> a) -> S z s a
gets forall s. Env s -> Arr s Int
rnE
-- r     <- gets rootE
(Int
_,Int
n) <- forall z a s. ST z a -> S z s a
st (forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds Arr s Int
dom)
forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m (t b)
forM [Int
1..Int
n] (\Int
i-> do
Int
j <- forall z a s. ST z a -> S z s a
st(Arr s Int
rnforall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!:Int
i)
Int
d <- forall z a s. ST z a -> S z s a
st(Arr s Int
domforall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!:Int
i)
Int
k <- forall z a s. ST z a -> S z s a
st(Arr s Int
rnforall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!:Int
d)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
j,Int
k))

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

zeroM :: Dom s Node
zeroM :: forall s. Dom s Int
zeroM = forall s a z. (s -> a) -> S z s a
gets forall s. Env s -> Int
zeroE
domM :: Node -> Dom s Node
domM :: forall s. Int -> Dom s Int
domM = forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch forall s. Env s -> Arr s Int
domE
rootM :: Dom s Node
rootM :: forall s. Dom s Int
rootM = forall s a z. (s -> a) -> S z s a
gets forall s. Env s -> Int
rootE
succsM :: Node -> Dom s [Node]
succsM :: forall s. Int -> Dom s Path
succsM Int
i = forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Monoid a => IntMap a -> Int -> a
! Int
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Env s -> Graph
succE)
predsM :: Node -> Dom s [Node]
predsM :: forall s. Int -> Dom s Path
predsM Int
i = forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Monoid a => IntMap a -> Int -> a
! Int
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Env s -> Graph
predE)
bucketM :: Node -> Dom s [Node]
bucketM :: forall s. Int -> Dom s Path
bucketM Int
i = forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Monoid a => IntMap a -> Int -> a
! Int
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Env s -> Graph
bucketE)
sizeM :: Node -> Dom s Int
sizeM :: forall s. Int -> Dom s Int
sizeM = forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch forall s. Env s -> Arr s Int
sizeE
sdnoM :: Node -> Dom s Int
sdnoM :: forall s. Int -> Dom s Int
sdnoM = forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch 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 = forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch forall s. Env s -> Arr s Int
ndfsE
childM :: Node -> Dom s Node
childM :: forall s. Int -> Dom s Int
childM = forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch forall s. Env s -> Arr s Int
childE
ancestorM :: Node -> Dom s Node
ancestorM :: forall s. Int -> Dom s Int
ancestorM = forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch forall s. Env s -> Arr s Int
ancestorE
parentM :: Node -> Dom s Node
parentM :: forall s. Int -> Dom s Int
parentM = forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch forall s. Env s -> Arr s Int
parentE
labelM :: Node -> Dom s Node
labelM :: forall s. Int -> Dom s Int
labelM = forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch forall s. Env s -> Arr s Int
labelE
nextM :: Dom s Int
nextM :: forall s. Dom s Int
nextM = do
Int
n <- forall s a z. (s -> a) -> S z s a
gets forall s. Env s -> Int
dfsE
let n' :: Int
n' = Int
nforall a. Num a => a -> a -> a
+Int
1
forall s z. (s -> s) -> S z s ()
modify(\Env s
e->Env s
e{dfsE :: Int
dfsE=Int
n'})
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 = 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 <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
a Int
i
forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
unsafeNewArray_ (Int
0,Int
nforall 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 = 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 = forall (t :: * -> *) (m :: * -> *) a b.
t a -> (a -> m b) -> m ()
forM_ [(Int, a)]
xs (\(Int
i,a
x) -> (Arr s a
aforall 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. a -> a
id (forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
n IntMap a
g)

fromAdj :: [(Node, [Node])] -> Graph
fromAdj :: [(Int, Path)] -> Graph
fromAdj = forall a. [(Int, a)] -> IntMap a
IM.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 = forall c a.
(c -> c -> c) -> (a -> Int) -> (a -> c) -> [a] -> IntMap c
collectI IntSet -> IntSet -> IntSet
IS.union forall a b. (a, b) -> a
fst (Int -> IntSet
IS.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)

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

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

predG :: Graph -> Graph
predG :: Graph -> Graph
predG Graph
g = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) Graph
g
go :: Graph -> Graph
go = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey forall a. Monoid a => a
mempty (\Int
i IntSet
a Graph
m ->
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Graph
m Int
p -> forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith 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
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. a -> a
id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Int -> IntMap a -> Maybe a
IM.lookup Graph
g) forall a b. (a -> b) -> a -> b
\$ Int
r
g2 :: Graph
g2 = forall a. [(Int, a)] -> IntMap a
IM.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> IntSet -> Bool
`IS.member`IntSet
is) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [(Int, a)]
IM.toList 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) = forall {f :: * -> *} {b} {b}.
Functor f =>
b -> f (Tree b) -> f (b, b)
p a
i [Tree a]
xs
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Tree a -> [(a, a)]
parents [Tree a]
xs
where p :: b -> f (Tree b) -> f (b, b)
p b
i = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) b
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> a
rootLabel)

ancestors :: Tree a -> [(a, [a])]
ancestors :: forall a. Tree a -> [(a, [a])]
ancestors = 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
iforall a. a -> [a] -> [a]
:[b]
acc
in forall {f :: * -> *} {b} {b}.
Functor f =>
b -> f (Tree b) -> f (b, b)
p [b]
acc' [Tree b]
xs forall a. [a] -> [a] -> [a]
++ 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) b
is forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Tree a -> (a, [Tree a])
tip) [Tree a]
ts
in (a
a, [a]
as) forall a. 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 = forall a. a -> [Tree a] -> Tree a
Node Int
a (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Tree Int
go ((IntSet -> Path
IS.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntSet
f) Int
a))
f :: Int -> IntSet
f = (Graph
g 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 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
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\IntMap c
m a
a -> 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) 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))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = 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,forall a. Monoid a => a
mempty) IntSet
ss
new2 :: Graph
new2 = 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,forall a. Monoid a => a
mempty,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 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
nforall a. Num a => a -> a -> a
+Int
1,forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Int
n NodeMap Int
env)

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

-- Nothing better than reinvinting 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}
instance Functor (S z s) where
fmap :: forall a b. (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 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 -> forall o. (a -> s -> ST z o) -> s -> ST z o
g (b -> s -> ST z o
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
instance Monad (S z s) where
return :: forall a. a -> S z s a
return = 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 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 -> forall o. (a -> s -> ST z o) -> s -> ST z o
g (\a
a -> 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 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
(<*>) = 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 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 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 () 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) = forall o. (a -> s -> ST z o) -> s -> ST z o
g ((forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 <- forall s a z. (s -> a) -> S z s a
gets s -> Arr z a
f
forall z a s. ST z a -> S z s a
st ((Arr z a
aforall 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 <- forall s a z. (s -> a) -> S z s a
gets s -> Arr z a
f
forall z a s. ST z a -> S z s a
st (Arr z a
aforall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!:Int
i)
```