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

{- |
  Module      :  Dominators
  Copyright   :  (c) Matt Morrow 2009
  License     :  BSD3
  Maintainer  :  <morrow@moonpatio.com>
  Stability   :  experimental
  Portability :  portable

  Taken from the dom-lt package.

  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.

  Originally taken from the dom-lt package.
-}

module Dominators (
   Node,Path,Edge
  ,Graph,Rooted
  ,idom,ipdom
  ,domTree,pdomTree
  ,dom,pdom
  ,pddfs,rpddfs
  ,fromAdj,fromEdges
  ,toAdj,toEdges
  ,asTree,asGraph
  ,parents,ancestors
) where

import GhcPrelude

import Data.Bifunctor
import Data.Tuple (swap)

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

import Control.Monad
import Control.Monad.ST.Strict

import Data.Array.ST
import Data.Array.Base hiding ((!))
  -- (unsafeNewArray_

  -- ,unsafeWrite,unsafeRead

  -- ,readArray,writeArray)


import Util (debugIsOn)

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


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 (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Graph -> Graph
predG Rooted
rg)))

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


-- | /Post-dominated depth-first search/.

pddfs :: Rooted -> [Node]
pddfs :: Rooted -> Path
pddfs = Path -> Path
forall a. [a] -> [a]
reverse (Path -> Path) -> (Rooted -> Path) -> Rooted -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Path
rpddfs

-- | /Reverse post-dominated depth-first search/.

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

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


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

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

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


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

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


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

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


initEnv :: Rooted -> ST s (Env s)
initEnv :: Rooted -> ST s (Env s)
initEnv (Node
r0,Graph
g0) = do
  let (Graph
g,NodeMap Node
rnmap) = Node -> Graph -> (Graph, NodeMap Node)
renum Node
1 Graph
g0
      pred :: Graph
pred      = Graph -> Graph
predG Graph
g
      r :: Node
r         = NodeMap Node
rnmap NodeMap Node -> Node -> Node
forall a. IntMap a -> Node -> a
IM.! Node
r0
      n :: Node
n         = Graph -> Node
forall a. IntMap a -> Node
IM.size Graph
g
      ns :: Path
ns        = [Node
0..Node
n]
      m :: Node
m         = Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
1

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

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

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

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

  (Arr s Node
domsArr s Node -> Node -> Node -> ST s ()
forall s a.
MArray (A s) a (ST s) =>
Arr s a -> a -> Node -> ST s ()
.=Node
r) Node
r
  (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
r
    ,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 .=

(.=) :: (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
  | Bool
debugIsOn = Arr s a -> Node -> a -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray Arr s a
v Node
i a
x
  | Bool
otherwise = 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
  | Bool
debugIsOn = 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 -> i -> m e
readArray 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
  | Bool
otherwise = 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 (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p 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 (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p 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
        f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet
        f :: Graph -> Node -> IntSet -> Graph
f Graph
m Node
i IntSet
a = (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)
        go :: IntMap IntSet -> IntMap IntSet
        go :: Graph -> Graph
go = ((Graph -> Node -> IntSet -> Graph) -> Graph -> Graph -> Graph)
-> Graph -> (Graph -> Node -> IntSet -> Graph) -> Graph -> Graph
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Graph -> Node -> IntSet -> Graph) -> Graph -> Graph -> Graph
forall a b. (a -> Node -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey' Graph
forall a. Monoid a => a
mempty Graph -> Node -> IntSet -> Graph
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 (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p 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


-- (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, NodeMap Node, Graph)
 -> Node -> IntSet -> (Node, NodeMap Node, Graph))
-> (Node, NodeMap Node, Graph)
-> Graph
-> (Node, NodeMap Node, Graph)
forall a b. (a -> Node -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey'
      (Node, NodeMap Node, Graph)
-> Node -> IntSet -> (Node, NodeMap Node, Graph)
f (Node
from,NodeMap Node
forall a. Monoid a => a
mempty,Graph
forall a. Monoid a => a
mempty)
  where
    f :: (Int, NodeMap Node, IntMap IntSet) -> Node -> IntSet
      -> (Int, NodeMap Node, IntMap IntSet)
    f :: (Node, NodeMap Node, Graph)
-> Node -> IntSet -> (Node, NodeMap Node, Graph)
f (!Node
n,!NodeMap Node
env,!Graph
new) Node
i IntSet
ss =
            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)
    go :: Int
        -> NodeMap Node
        -> Node
        -> (Node,Int,NodeMap Node)
    go :: Node -> NodeMap Node -> Node -> (Node, Node, NodeMap Node)
go !Node
n !NodeMap Node
env Node
i =
        case Node -> NodeMap Node -> Maybe Node
forall a. Node -> IntMap a -> Maybe a
IM.lookup Node
i NodeMap Node
env of
        Just Node
j -> (Node
j,Node
n,NodeMap Node
env)
        Maybe Node
Nothing -> (Node
n,Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
1,Node -> Node -> NodeMap Node -> NodeMap Node
forall a. Node -> a -> IntMap a -> IntMap a
IM.insert Node
i Node
n NodeMap Node
env)

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


newtype S z s a = S {S z s a -> forall o. (a -> s -> ST z o) -> s -> ST z o
unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}
instance Functor (S z s) where
  fmap :: (a -> b) -> S z s a -> S z s b
fmap a -> b
f (S forall o. (a -> s -> ST z o) -> s -> ST z o
g) = (forall o. (b -> s -> ST z o) -> s -> ST z o) -> S z s b
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\b -> s -> ST z o
k -> (a -> s -> ST z o) -> s -> ST z o
forall o. (a -> s -> ST z o) -> s -> ST z o
g (b -> s -> ST z o
k (b -> s -> ST z o) -> (a -> b) -> a -> s -> ST z o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
instance Monad (S z s) where
  return :: a -> S z s a
return = a -> S z s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  S forall o. (a -> s -> ST z o) -> s -> ST z o
g >>= :: S z s a -> (a -> S z s b) -> S z s b
>>= a -> S z s b
f = (forall o. (b -> s -> ST z o) -> s -> ST z o) -> S z s b
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\b -> s -> ST z o
k -> (a -> s -> ST z o) -> s -> ST z o
forall o. (a -> s -> ST z o) -> s -> ST z o
g (\a
a -> S z s b -> (b -> s -> ST z o) -> s -> ST z o
forall z s a.
S z s a -> forall o. (a -> s -> ST z o) -> s -> ST z o
unS (a -> S z s b
f a
a) b -> s -> ST z o
k))
instance Applicative (S z s) where
  pure :: a -> S z s a
pure a
a = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k -> a -> s -> ST z o
k a
a)
  <*> :: S z s (a -> b) -> S z s a -> S z s b
(<*>) = S z s (a -> b) -> S z s a -> S z s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
-- 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)