{-# 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)

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

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 -> [(Node, Path)]
dom = Tree Node -> [(Node, Path)]
forall a. Tree a -> [(a, [a])]
ancestors (Tree Node -> [(Node, Path)])
-> (Rooted -> Tree Node) -> Rooted -> [(Node, Path)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Node
domTree

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

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

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

-- | /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 -> [(Node, Node)]
idom Rooted
rg = (forall s. ST s [(Node, Node)]) -> [(Node, Node)]
forall a. (forall s. ST s a) -> a
runST (S s (Env s) [(Node, Node)] -> Env s -> ST s [(Node, Node)]
forall z s a. S z s a -> s -> ST z a
evalS S s (Env s) [(Node, Node)]
forall s. Dom s [(Node, Node)]
idomM (Env s -> ST s [(Node, Node)])
-> ST s (Env s) -> ST s [(Node, Node)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Rooted -> ST s (Env s)
forall s. Rooted -> ST s (Env s)
initEnv (Rooted -> Rooted
pruneReach Rooted
rg))

-- | /Immediate post-dominators/.
-- Complexity as for @idom@.
ipdom :: Rooted -> [(Node,Node)]
ipdom :: Rooted -> [(Node, Node)]
ipdom Rooted
rg = (forall s. ST s [(Node, Node)]) -> [(Node, Node)]
forall a. (forall s. ST s a) -> a
runST (S s (Env s) [(Node, Node)] -> Env s -> ST s [(Node, Node)]
forall z s a. S z s a -> s -> ST z a
evalS S s (Env s) [(Node, Node)]
forall s. Dom s [(Node, Node)]
idomM (Env s -> ST s [(Node, Node)])
-> ST s (Env s) -> ST s [(Node, Node)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Rooted -> ST s (Env s)
forall s. Rooted -> ST s (Env s)
initEnv (Rooted -> Rooted
pruneReach ((Graph -> Graph) -> Rooted -> Rooted
forall b c a. (b -> c) -> (a, b) -> (a, c)
second Graph -> Graph
predG Rooted
rg)))

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

-- | /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 Node -> [Path]
forall a. Tree a -> [[a]]
levels (Tree Node -> [Path]) -> (Rooted -> Tree Node) -> Rooted -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Node
pdomTree

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

zeroM :: Dom s Node
zeroM :: Dom s Node
zeroM = (Env s -> Node) -> Dom s Node
forall s a z. (s -> a) -> S z s a
gets Env s -> Node
forall s. Env s -> Node
zeroE
domM :: Node -> Dom s Node
domM :: Node -> Dom s Node
domM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
domE
rootM :: Dom s Node
rootM :: Dom s Node
rootM = (Env s -> Node) -> Dom s Node
forall s a z. (s -> a) -> S z s a
gets Env s -> Node
forall s. Env s -> Node
rootE
succsM :: Node -> Dom s [Node]
succsM :: Node -> Dom s Path
succsM Node
i = (Env s -> Path) -> Dom s Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph -> Node -> IntSet
forall a. Monoid a => IntMap a -> Node -> a
! Node
i) (Graph -> IntSet) -> (Env s -> Graph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> Graph
forall s. Env s -> Graph
succE)
predsM :: Node -> Dom s [Node]
predsM :: Node -> Dom s Path
predsM Node
i = (Env s -> Path) -> Dom s Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph -> Node -> IntSet
forall a. Monoid a => IntMap a -> Node -> a
! Node
i) (Graph -> IntSet) -> (Env s -> Graph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> Graph
forall s. Env s -> Graph
predE)
bucketM :: Node -> Dom s [Node]
bucketM :: Node -> Dom s Path
bucketM Node
i = (Env s -> Path) -> Dom s Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph -> Node -> IntSet
forall a. Monoid a => IntMap a -> Node -> a
! Node
i) (Graph -> IntSet) -> (Env s -> Graph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> Graph
forall s. Env s -> Graph
bucketE)
sizeM :: Node -> Dom s Int
sizeM :: Node -> Dom s Node
sizeM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
sizeE
sdnoM :: Node -> Dom s Int
sdnoM :: Node -> Dom s Node
sdnoM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
sdnoE
-- dfnM :: Node -> Dom s Int
-- dfnM = fetch dfnE
ndfsM :: Int -> Dom s Node
ndfsM :: Node -> Dom s Node
ndfsM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
ndfsE
childM :: Node -> Dom s Node
childM :: Node -> Dom s Node
childM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
childE
ancestorM :: Node -> Dom s Node
ancestorM :: Node -> Dom s Node
ancestorM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
ancestorE
parentM :: Node -> Dom s Node
parentM :: Node -> Dom s Node
parentM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
parentE
labelM :: Node -> Dom s Node
labelM :: Node -> Dom s Node
labelM = (Env s -> Arr s Node) -> Node -> Dom s Node
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Node -> S z s a
fetch Env s -> Arr s Node
forall s. Env s -> Arr s Node
labelE
nextM :: Dom s Int
nextM :: Dom s Node
nextM = do
  Node
n <- (Env s -> Node) -> Dom s Node
forall s a z. (s -> a) -> S z s a
gets Env s -> Node
forall s. Env s -> Node
dfsE
  let n' :: Node
n' = Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
1
  (Env s -> Env s) -> S s (Env s) ()
forall s z. (s -> s) -> S z s ()
modify(\Env s
e->Env s
e{dfsE :: Node
dfsE=Node
n'})
  Node -> Dom s Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
n'

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

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

infixl 9 !:
infixr 2 .=

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

(!:) :: (MArray (A s) a (ST s))
     => A s Int a -> Int -> ST s a
A s Node a
a !: :: A s Node a -> Node -> ST s a
!: Node
i = do
  a
o <- A s Node a -> Node -> ST s a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Node -> m e
unsafeRead A s Node a
a Node
i
  a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ST s a) -> a -> ST s a
forall a b. (a -> b) -> a -> b
$! a
o

new :: (MArray (A s) a (ST s))
    => Int -> ST s (Arr s a)
new :: Node -> ST s (Arr s a)
new Node
n = (Node, Node) -> ST s (Arr s a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
unsafeNewArray_ (Node
0,Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
-Node
1)

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

-- 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 :: Arr s a -> [(Node, a)] -> ST s ()
writes Arr s a
a [(Node, a)]
xs = [(Node, a)] -> ((Node, a) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Node, a)]
xs (\(Node
i,a
x) -> (Arr s a
aArr s a -> a -> Node -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=a
x) Node
i)

-- 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
(!) IntMap a
g Node
n = a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
forall a. Monoid a => a
mempty a -> a
forall a. a -> a
id (Node -> IntMap a -> Maybe a
forall a. Node -> IntMap a -> Maybe a
IM.lookup Node
n IntMap a
g)

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

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

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

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

predG :: Graph -> Graph
predG :: Graph -> Graph
predG Graph
g = (IntSet -> IntSet -> IntSet) -> Graph -> Graph -> Graph
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntSet -> IntSet -> IntSet
IS.union (Graph -> Graph
go Graph
g) Graph
g0
  where g0 :: Graph
g0 = (IntSet -> IntSet) -> Graph -> Graph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IntSet -> IntSet -> IntSet
forall a b. a -> b -> a
const IntSet
forall a. Monoid a => a
mempty) Graph
g
        go :: Graph -> Graph
go = ((Node -> IntSet -> Graph -> Graph) -> Graph -> Graph -> Graph)
-> Graph -> (Node -> IntSet -> Graph -> Graph) -> Graph -> Graph
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Node -> IntSet -> Graph -> Graph) -> Graph -> Graph -> Graph
forall a b. (Node -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey Graph
forall a. Monoid a => a
mempty (\Node
i IntSet
a Graph
m ->
                (Graph -> Node -> Graph) -> Graph -> Path -> Graph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Graph
m Node
p -> (IntSet -> IntSet -> IntSet) -> Node -> IntSet -> Graph -> Graph
forall a. (a -> a -> a) -> Node -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
forall a. Monoid a => a -> a -> a
mappend Node
p
                                      (Node -> IntSet
IS.singleton Node
i) Graph
m)
                        Graph
m
                       (IntSet -> Path
IS.toList IntSet
a))

-- 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 (Node
r,Graph
g) = (Node
r,Graph
g2)
  where is :: IntSet
is = (Node -> IntSet) -> Node -> IntSet
reachable
              (IntSet -> (IntSet -> IntSet) -> Maybe IntSet -> IntSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IntSet
forall a. Monoid a => a
mempty IntSet -> IntSet
forall a. a -> a
id
                (Maybe IntSet -> IntSet)
-> (Node -> Maybe IntSet) -> Node -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Graph -> Maybe IntSet) -> Graph -> Node -> Maybe IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node -> Graph -> Maybe IntSet
forall a. Node -> IntMap a -> Maybe a
IM.lookup Graph
g) (Node -> IntSet) -> Node -> IntSet
forall a b. (a -> b) -> a -> b
$ Node
r
        g2 :: Graph
g2 = [(Node, IntSet)] -> Graph
forall a. [(Node, a)] -> IntMap a
IM.fromList
            ([(Node, IntSet)] -> Graph)
-> (Graph -> [(Node, IntSet)]) -> Graph -> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Node, IntSet) -> (Node, IntSet))
-> [(Node, IntSet)] -> [(Node, IntSet)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IntSet -> IntSet) -> (Node, IntSet) -> (Node, IntSet)
forall b c a. (b -> c) -> (a, b) -> (a, c)
second ((Node -> Bool) -> IntSet -> IntSet
IS.filter (Node -> IntSet -> Bool
`IS.member`IntSet
is)))
            ([(Node, IntSet)] -> [(Node, IntSet)])
-> (Graph -> [(Node, IntSet)]) -> Graph -> [(Node, IntSet)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Node, IntSet) -> Bool) -> [(Node, IntSet)] -> [(Node, IntSet)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Node -> IntSet -> Bool
`IS.member`IntSet
is) (Node -> Bool)
-> ((Node, IntSet) -> Node) -> (Node, IntSet) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, IntSet) -> Node
forall a b. (a, b) -> a
fst)
            ([(Node, IntSet)] -> [(Node, IntSet)])
-> (Graph -> [(Node, IntSet)]) -> Graph -> [(Node, IntSet)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [(Node, IntSet)]
forall a. IntMap a -> [(Node, a)]
IM.toList (Graph -> Graph) -> Graph -> Graph
forall a b. (a -> b) -> a -> b
$ Graph
g

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

parents :: Tree a -> [(a, a)]
parents :: Tree a -> [(a, a)]
parents (Node a
i Forest a
xs) = a -> Forest a -> [(a, a)]
forall (f :: * -> *) b a. Functor f => b -> f (Tree a) -> f (a, b)
p a
i Forest a
xs
        [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ (Tree a -> [(a, a)]) -> Forest a -> [(a, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [(a, a)]
forall a. Tree a -> [(a, a)]
parents Forest a
xs
  where p :: b -> f (Tree a) -> f (a, b)
p b
i = (Tree a -> (a, b)) -> f (Tree a) -> f (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b -> (a, b)) -> b -> a -> (a, b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) b
i (a -> (a, b)) -> (Tree a -> a) -> Tree a -> (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> a
forall a. Tree a -> a
rootLabel)

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

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

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

reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
reachable :: (Node -> IntSet) -> Node -> IntSet
reachable Node -> IntSet
f Node
a = IntSet -> Node -> IntSet
go (Node -> IntSet
IS.singleton Node
a) Node
a
  where go :: IntSet -> Node -> IntSet
go IntSet
seen Node
a = let s :: IntSet
s = Node -> IntSet
f Node
a
                        as :: Path
as = IntSet -> Path
IS.toList (IntSet
s IntSet -> IntSet -> IntSet
`IS.difference` IntSet
seen)
                    in (IntSet -> Node -> IntSet) -> IntSet -> Path -> IntSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntSet -> Node -> IntSet
go (IntSet
s IntSet -> IntSet -> IntSet
`IS.union` IntSet
seen) Path
as

collectI :: (c -> c -> c)
        -> (a -> Int) -> (a -> c) -> [a] -> IntMap c
collectI :: (c -> c -> c) -> (a -> Node) -> (a -> c) -> [a] -> IntMap c
collectI c -> c -> c
(<>) a -> Node
f a -> c
g
  = (IntMap c -> a -> IntMap c) -> IntMap c -> [a] -> IntMap c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\IntMap c
m a
a -> (c -> c -> c) -> Node -> c -> IntMap c -> IntMap c
forall a. (a -> a -> a) -> Node -> a -> IntMap a -> IntMap a
IM.insertWith c -> c -> c
(<>)
                                  (a -> Node
f a
a)
                                  (a -> c
g a
a) IntMap c
m) IntMap c
forall a. Monoid a => a
mempty

-- 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 :: Node -> Graph -> (Graph, NodeMap Node)
renum Node
from = (\(Node
_,NodeMap Node
m,Graph
g)->(Graph
g,NodeMap Node
m))
  ((Node, NodeMap Node, Graph) -> (Graph, NodeMap Node))
-> (Graph -> (Node, NodeMap Node, Graph))
-> Graph
-> (Graph, NodeMap Node)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node
 -> IntSet
 -> (Node, NodeMap Node, Graph)
 -> (Node, NodeMap Node, Graph))
-> (Node, NodeMap Node, Graph)
-> Graph
-> (Node, NodeMap Node, Graph)
forall a b. (Node -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey
      (\Node
i IntSet
ss (!Node
n,!NodeMap Node
env,!Graph
new)->
          let (Node
j,Node
n2,NodeMap Node
env2) = Node -> NodeMap Node -> Node -> (Node, Node, NodeMap Node)
go Node
n NodeMap Node
env Node
i
              (Node
n3,NodeMap Node
env3,IntSet
ss2) = (Node
 -> (Node, NodeMap Node, IntSet) -> (Node, NodeMap Node, IntSet))
-> (Node, NodeMap Node, IntSet)
-> IntSet
-> (Node, NodeMap Node, IntSet)
forall b. (Node -> b -> b) -> b -> IntSet -> b
IS.fold
                (\Node
k (!Node
n,!NodeMap Node
env,!IntSet
new)->
                    case Node -> NodeMap Node -> Node -> (Node, Node, NodeMap Node)
go Node
n NodeMap Node
env Node
k of
                      (Node
l,Node
n2,NodeMap Node
env2)-> (Node
n2,NodeMap Node
env2,Node
l Node -> IntSet -> IntSet
`IS.insert` IntSet
new))
                (Node
n2,NodeMap Node
env2,IntSet
forall a. Monoid a => a
mempty) IntSet
ss
              new2 :: Graph
new2 = (IntSet -> IntSet -> IntSet) -> Node -> IntSet -> Graph -> Graph
forall a. (a -> a -> a) -> Node -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
IS.union Node
j IntSet
ss2 Graph
new
          in (Node
n3,NodeMap Node
env3,Graph
new2)) (Node
from,NodeMap Node
forall a. Monoid a => a
mempty,Graph
forall a. Monoid a => a
mempty)
  where go :: Int
           -> NodeMap Node
           -> Node
           -> (Node,Int,NodeMap Node)
        go :: Node -> NodeMap Node -> Node -> (Node, Node, NodeMap Node)
go !Node
n !NodeMap Node
env Node
i =
          case Node -> NodeMap Node -> Maybe Node
forall a. Node -> IntMap a -> Maybe a
IM.lookup Node
i NodeMap Node
env of
            Just Node
j -> (Node
j,Node
n,NodeMap Node
env)
            Maybe Node
Nothing -> (Node
n,Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
1,Node -> Node -> NodeMap Node -> NodeMap Node
forall a. Node -> a -> IntMap a -> IntMap a
IM.insert Node
i Node
n NodeMap Node
env)

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

-- Nothing better than reinvinting the state monad.
newtype S z s a = S {S z s a -> forall o. (a -> s -> ST z o) -> s -> ST z o
unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}
instance Functor (S z s) where
  fmap :: (a -> b) -> S z s a -> S z s b
fmap a -> b
f (S forall o. (a -> s -> ST z o) -> s -> ST z o
g) = (forall o. (b -> s -> ST z o) -> s -> ST z o) -> S z s b
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\b -> s -> ST z o
k -> (a -> s -> ST z o) -> s -> ST z o
forall o. (a -> s -> ST z o) -> s -> ST z o
g (b -> s -> ST z o
k (b -> s -> ST z o) -> (a -> b) -> a -> s -> ST z o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
instance Monad (S z s) where
  return :: a -> S z s a
return = a -> S z s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  S forall o. (a -> s -> ST z o) -> s -> ST z o
g >>= :: S z s a -> (a -> S z s b) -> S z s b
>>= a -> S z s b
f = (forall o. (b -> s -> ST z o) -> s -> ST z o) -> S z s b
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\b -> s -> ST z o
k -> (a -> s -> ST z o) -> s -> ST z o
forall o. (a -> s -> ST z o) -> s -> ST z o
g (\a
a -> S z s b -> (b -> s -> ST z o) -> s -> ST z o
forall z s a.
S z s a -> forall o. (a -> s -> ST z o) -> s -> ST z o
unS (a -> S z s b
f a
a) b -> s -> ST z o
k))
instance Applicative (S z s) where
  pure :: a -> S z s a
pure a
a = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k -> a -> s -> ST z o
k a
a)
  <*> :: S z s (a -> b) -> S z s a -> S z s b
(<*>) = S z s (a -> b) -> S z s a -> S z s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
-- get :: S z s s
-- get = S (\k s -> k s s)
gets :: (s -> a) -> S z s a
gets :: (s -> a) -> S z s a
gets s -> a
f = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k s
s -> a -> s -> ST z o
k (s -> a
f s
s) s
s)
-- set :: s -> S z s ()
-- set s = S (\k _ -> k () s)
modify :: (s -> s) -> S z s ()
modify :: (s -> s) -> S z s ()
modify s -> s
f = (forall o. (() -> s -> ST z o) -> s -> ST z o) -> S z s ()
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\() -> s -> ST z o
k -> () -> s -> ST z o
k () (s -> ST z o) -> (s -> s) -> s -> ST z o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
f)
-- 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 :: S z s a -> s -> ST z a
evalS (S forall o. (a -> s -> ST z o) -> s -> ST z o
g) = (a -> s -> ST z a) -> s -> ST z a
forall o. (a -> s -> ST z o) -> s -> ST z o
g ((a -> ST z a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ST z a) -> (s -> a) -> s -> ST z a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((s -> a) -> s -> ST z a) -> (a -> s -> a) -> a -> s -> ST z a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> s -> a
forall a b. a -> b -> a
const)
-- 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 :: ST z a -> S z s a
st ST z a
m = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k s
s-> do
  a
a <- ST z a
m
  a -> s -> ST z o
k a
a s
s)
store :: (MArray (A z) a (ST z))
      => (s -> Arr z a) -> Int -> a -> S z s ()
store :: (s -> Arr z a) -> Node -> a -> S z s ()
store s -> Arr z a
f Node
i a
x = do
  Arr z a
a <- (s -> Arr z a) -> S z s (Arr z a)
forall s a z. (s -> a) -> S z s a
gets s -> Arr z a
f
  ST z () -> S z s ()
forall z a s. ST z a -> S z s a
st ((Arr z a
aArr z a -> a -> Node -> ST z ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=a
x) Node
i)
fetch :: (MArray (A z) a (ST z))
      => (s -> Arr z a) -> Int -> S z s a
fetch :: (s -> Arr z a) -> Node -> S z s a
fetch s -> Arr z a
f Node
i = do
  Arr z a
a <- (s -> Arr z a) -> S z s (Arr z a)
forall s a z. (s -> a) -> S z s a
gets s -> Arr z a
f
  ST z a -> S z s a
forall z a s. ST z a -> S z s a
st (Arr z a
aArr z a -> Node -> ST z a
forall s a. MArray (A s) a (ST s) => A s Node a -> Node -> ST s a
!:Node
i)

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