{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts #-}

#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE Strict #-}
#endif

{- |
  Module      :  Data.Graph.Dom
  Copyright   :  (c) Matt Morrow 2009
  License     :  BSD3
  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.

    \[3\] Brisk, Sarrafzadeh,
      /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 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)

import Data.Maybe

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

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)
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.
(Foldable t, Monad m) =>
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.
(Foldable t, Monad m) =>
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
e{bucketE=IM.adjust
                      (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 ()
link Int
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.
(Foldable t, Monad m) =>
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.
(Foldable t, Monad m) =>
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 ()
link Int
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 -> S s (Env s) Int
balance Int
s = do
        Int
c   <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
childM Int
s
        Int
lc  <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
labelM Int
c
        Int
slc <- Int -> S s (Env 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 -> S s (Env 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 -> S s (Env s) Int
forall s. Int -> Dom s Int
sizeM Int
s
            Int
zc  <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sizeM Int
c
            Int
cc  <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
childM Int
c
            Int
zcc <- Int -> S s (Env 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 -> 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
ancestorE Int
c Int
s
                (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
childE Int
s Int
cc
                Int -> S s (Env s) Int
balance Int
s
              Bool
False-> 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
sizeE Int
c Int
zs
                (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
ancestorE Int
s Int
c
                Int -> S s (Env s) Int
balance Int
c
  Int
s   <- Int -> Dom s Int
forall 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 -> S z (Env z) ()
follow Int
s = do
        Bool -> S z (Env z) () -> S z (Env z) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n0) (do
          (Env z -> Arr z Int) -> Int -> Int -> S z (Env z) ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env z -> Arr z Int
forall s. Env s -> Arr s Int
ancestorE Int
s Int
v
          Int -> S z (Env z) ()
follow (Int -> S z (Env z) ()) -> S z (Env z) Int -> S z (Env z) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> S z (Env z) 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 ()
forall s. 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.
(Foldable t, Monad m) =>
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.
(Foldable t, Monad m) =>
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.
(Foldable t, Monad m) =>
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.
(Foldable t, Monad m) =>
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.
(Foldable t, Monad m) =>
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.
(Foldable t, Monad m) =>
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.
(Traversable t, Monad m) =>
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
unsafeRead A s Int a
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

-- newD :: Int -> ST s (Arr s Double)
-- newD = new

-- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a]
-- dump a = do
--   (m,n) <- getBounds a
--   forM [m..n] (\i -> a!:i)

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.
(Foldable t, Monad m) =>
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)

-- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a)
-- arr xs = do
--   let n = length xs
--   a <- new n
--   go a n 0 xs
--   return a
--   where go _ _ _    [] = return ()
--         go a n i (x:xs)
--           | i <= n = (a.=x) i >> go a n (i+1) xs
--           | otherwise = return ()

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

(!) :: 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)
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)
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)]
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 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))

-- predG :: Graph -> Graph
-- predG g = IM.unionWith IS.union (go g) g0
--   where g0 = fmap (const mempty) g
--         f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet
--         f m i a = foldl' (\m p -> IM.insertWith mappend p
--                                       (IS.singleton i) m)
--                         m
--                        (IS.toList a)
--         go :: IntMap IntSet -> IntMap IntSet
--         go = flip IM.foldlWithKey' mempty f

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 -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
fromMaybe IntSet
forall a. Monoid a => a
mempty
                (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 = (IntSet -> IntSet) -> Graph -> Graph
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map (\IntSet
targets -> (Int -> Bool) -> IntSet -> IntSet
IS.filter (Int -> IntSet -> Bool
`IS.member`IntSet
is) IntSet
targets)
            (Graph -> Graph) -> (Graph -> Graph) -> Graph -> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IntSet -> Bool) -> Graph -> Graph
forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IM.filterWithKey (\Int
node IntSet
_targets -> Int -> IntSet -> Bool
IS.member Int
node IntSet
is) (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
fromAdj [(Int, Path)]
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

-- collect :: (Ord b) => (c -> c -> c)
--         -> (a -> b) -> (a -> c) -> [a] -> Map b c
-- collect (<>) f g
--   = foldl' (\m a -> SM.insertWith (<>)
--                                   (f a)
--                                   (g a) m) 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 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 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 :: 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)

-- Redefine Data.Bifunctor.second for GHC 7 compatibility
second :: (b -> c) -> (a, b) -> (a, c)
second :: forall b c a. (b -> c) -> (a, b) -> (a, c)
second b -> c
f (a
a, b
b) = (a
a, b -> c
f b
b)