{-# 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 GHC.CmmToAsm.CFG.Dominators (
   Node,Path,Edge
  ,Graph,Rooted
  ,idom,ipdom
  ,domTree,pdomTree
  ,dom,pdom
  ,pddfs,rpddfs
  ,fromAdj,fromEdges
  ,toAdj,toEdges
  ,asTree,asGraph
  ,parents,ancestors
) where

import GHC.Prelude

import Data.Bifunctor
import Data.Tuple (swap)

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

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

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

  -- ,unsafeWrite,unsafeRead

  -- ,readArray,writeArray)


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

-- | /Post-dominators/.

-- Complexity as for @idom@.

pdom :: Rooted -> [(Node, Path)]
pdom :: Rooted -> [(Int, Path)]
pdom = Tree Int -> [(Int, Path)]
forall a. Tree a -> [(a, [a])]
ancestors (Tree Int -> [(Int, Path)])
-> (Rooted -> Tree Int) -> Rooted -> [(Int, Path)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Int
pdomTree

-- | /Dominator tree/.

-- Complexity as for @idom@.

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

-- | /Post-dominator tree/.

-- Complexity as for @idom@.

pdomTree :: Rooted -> Tree Node
pdomTree :: Rooted -> Tree Int
pdomTree a :: Rooted
a@(Int
r,IntMap IntSet
_) =
  let is :: [(Int, Int)]
is = ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
r)(Int -> Bool) -> ((Int, Int) -> Int) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int, Int) -> Int
forall a b. (a, b) -> a
fst) (Rooted -> [(Int, Int)]
ipdom Rooted
a)
      tg :: IntMap IntSet
tg = [(Int, Int)] -> IntMap IntSet
fromEdges (((Int, Int) -> (Int, Int)) -> [(Int, Int)] -> [(Int, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> (Int, Int)
forall a b. (a, b) -> (b, a)
swap [(Int, Int)]
is)
  in Rooted -> Tree Int
asTree (Int
r,IntMap IntSet
tg)

-- | /Immediate dominators/.

-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is

-- \"a functional inverse of Ackermann's function\".

--

-- This Complexity bound assumes /O(1)/ indexing. Since we're

-- using @IntMap@, it has an additional /lg |V|/ factor

-- somewhere in there. I'm not sure where.

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

-- | /Immediate post-dominators/.

-- Complexity as for @idom@.

ipdom :: Rooted -> [(Node,Node)]
ipdom :: Rooted -> [(Int, Int)]
ipdom Rooted
rg = (forall s. ST s [(Int, Int)]) -> [(Int, Int)]
forall a. (forall s. ST s a) -> a
runST (S s (Env s) [(Int, Int)] -> Env s -> ST s [(Int, Int)]
forall z s a. S z s a -> s -> ST z a
evalS S s (Env s) [(Int, Int)]
forall s. Dom s [(Int, Int)]
idomM (Env s -> ST s [(Int, Int)]) -> ST s (Env s) -> ST s [(Int, Int)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Rooted -> ST s (Env s)
forall s. Rooted -> ST s (Env s)
initEnv (Rooted -> Rooted
pruneReach ((IntMap IntSet -> IntMap IntSet) -> Rooted -> Rooted
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second IntMap IntSet -> IntMap IntSet
predG Rooted
rg)))

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


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

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

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

rpddfs :: Rooted -> [Node]
rpddfs :: Rooted -> Path
rpddfs = [Path] -> Path
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Path] -> Path) -> (Rooted -> [Path]) -> Rooted -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Int -> [Path]
forall a. Tree a -> [[a]]
levels (Tree Int -> [Path]) -> (Rooted -> Tree Int) -> Rooted -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Int
pdomTree

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


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

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


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

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


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

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

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


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

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


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

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


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

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

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

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

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

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

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

fromEnv :: Dom s [(Node,Node)]
fromEnv :: forall s. Dom s [(Int, Int)]
fromEnv = do
  Arr s Int
dom   <- (Env s -> Arr s Int) -> S s (Env s) (Arr s Int)
forall s a z. (s -> a) -> S z s a
gets Env s -> Arr s Int
forall s. Env s -> Arr s Int
domE
  Arr s Int
rn    <- (Env s -> Arr s Int) -> S s (Env s) (Arr s Int)
forall s a z. (s -> a) -> S z s a
gets Env s -> Arr s Int
forall s. Env s -> Arr s Int
rnE
  -- r     <- gets rootE

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

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


zeroM :: Dom s Node
zeroM :: forall s. Dom s Int
zeroM = (Env s -> Int) -> S s (Env s) Int
forall s a z. (s -> a) -> S z s a
gets Env s -> Int
forall s. Env s -> Int
zeroE
domM :: Node -> Dom s Node
domM :: forall s. Int -> Dom s Int
domM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
domE
rootM :: Dom s Node
rootM :: forall s. Dom s Int
rootM = (Env s -> Int) -> S s (Env s) Int
forall s a z. (s -> a) -> S z s a
gets Env s -> Int
forall s. Env s -> Int
rootE
succsM :: Node -> Dom s [Node]
succsM :: forall s. Int -> Dom s Path
succsM Int
i = (Env s -> Path) -> S s (Env s) Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap IntSet -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
i) (IntMap IntSet -> IntSet)
-> (Env s -> IntMap IntSet) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> IntMap IntSet
forall s. Env s -> IntMap IntSet
succE)
predsM :: Node -> Dom s [Node]
predsM :: forall s. Int -> Dom s Path
predsM Int
i = (Env s -> Path) -> S s (Env s) Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap IntSet -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
i) (IntMap IntSet -> IntSet)
-> (Env s -> IntMap IntSet) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> IntMap IntSet
forall s. Env s -> IntMap IntSet
predE)
bucketM :: Node -> Dom s [Node]
bucketM :: forall s. Int -> Dom s Path
bucketM Int
i = (Env s -> Path) -> S s (Env s) Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap IntSet -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
i) (IntMap IntSet -> IntSet)
-> (Env s -> IntMap IntSet) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> IntMap IntSet
forall s. Env s -> IntMap IntSet
bucketE)
sizeM :: Node -> Dom s Int
sizeM :: forall s. Int -> Dom s Int
sizeM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
sizeE
sdnoM :: Node -> Dom s Int
sdnoM :: forall s. Int -> Dom s Int
sdnoM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
sdnoE
-- dfnM :: Node -> Dom s Int

-- dfnM = fetch dfnE

ndfsM :: Int -> Dom s Node
ndfsM :: forall s. Int -> Dom s Int
ndfsM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
ndfsE
childM :: Node -> Dom s Node
childM :: forall s. Int -> Dom s Int
childM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
childE
ancestorM :: Node -> Dom s Node
ancestorM :: forall s. Int -> Dom s Int
ancestorM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
ancestorE
parentM :: Node -> Dom s Node
parentM :: forall s. Int -> Dom s Int
parentM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
parentE
labelM :: Node -> Dom s Node
labelM :: forall s. Int -> Dom s Int
labelM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
labelE
nextM :: Dom s Int
nextM :: forall s. Dom s Int
nextM = do
  Int
n <- (Env s -> Int) -> Dom s Int
forall s a z. (s -> a) -> S z s a
gets Env s -> Int
forall s. Env s -> Int
dfsE
  let n' :: Int
n' = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
  (Env s -> Env s) -> S s (Env s) ()
forall s z. (s -> s) -> S z s ()
modify(\Env s
e->Env s
e{dfsE :: Int
dfsE=Int
n'})
  Int -> Dom s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'

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


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

infixl 9 !:
infixr 2 .=

(.=) :: (MArray (A s) a (ST s))
     => Arr s a -> a -> Int -> ST s ()
(Arr s a
v .= :: forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.= a
x) Int
i
  | Bool
debugIsOn = Arr s a -> Int -> 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 Int
i a
x
  | Bool
otherwise = Arr s a -> Int -> a -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite Arr s a
v Int
i a
x

(!:) :: (MArray (A s) a (ST s))
     => A s Int a -> Int -> ST s a
A s Int a
a !: :: forall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!: Int
i
  | Bool
debugIsOn = do
      a
o <- A s Int a -> Int -> ST s a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray A s Int a
a Int
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 Int a -> Int -> ST s a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead A s Int a
a Int
i
      a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ST s a) -> a -> ST s a
forall a b. (a -> b) -> a -> b
$! a
o

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

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

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

-- newD = new


-- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a]

-- dump a = do

--   (m,n) <- getBounds a

--   forM [m..n] (\i -> a!:i)


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

-- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a)

-- arr xs = do

--   let n = length xs

--   a <- new n

--   go a n 0 xs

--   return a

--   where go _ _ _    [] = return ()

--         go a n i (x:xs)

--           | i <= n = (a.=x) i >> go a n (i+1) xs

--           | otherwise = return ()


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


(!) :: Monoid a => IntMap a -> Int -> a
! :: forall a. Monoid a => IntMap a -> Int -> a
(!) IntMap a
g Int
n = a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
forall a. Monoid a => a
mempty a -> a
forall a. a -> a
id (Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
n IntMap a
g)

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

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

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

predG :: Graph -> Graph
predG :: IntMap IntSet -> IntMap IntSet
predG IntMap IntSet
g = (IntSet -> IntSet -> IntSet)
-> IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntSet -> IntSet -> IntSet
IS.union (IntMap IntSet -> IntMap IntSet
go IntMap IntSet
g) IntMap IntSet
g0
  where g0 :: IntMap IntSet
g0 = (IntSet -> IntSet) -> IntMap IntSet -> IntMap IntSet
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) IntMap IntSet
g
        f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet
        f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet
f IntMap IntSet
m Int
i IntSet
a = (IntMap IntSet -> Int -> IntMap IntSet)
-> IntMap IntSet -> Path -> IntMap IntSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\IntMap IntSet
m Int
p -> (IntSet -> IntSet -> IntSet)
-> Int -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
forall a. Monoid a => a -> a -> a
mappend Int
p
                                      (Int -> IntSet
IS.singleton Int
i) IntMap IntSet
m)
                        IntMap IntSet
m
                       (IntSet -> Path
IS.toList IntSet
a)
        go :: IntMap IntSet -> IntMap IntSet
        go :: IntMap IntSet -> IntMap IntSet
go = ((IntMap IntSet -> Int -> IntSet -> IntMap IntSet)
 -> IntMap IntSet -> IntMap IntSet -> IntMap IntSet)
-> IntMap IntSet
-> (IntMap IntSet -> Int -> IntSet -> IntMap IntSet)
-> IntMap IntSet
-> IntMap IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip (IntMap IntSet -> Int -> IntSet -> IntMap IntSet)
-> IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey' IntMap IntSet
forall a. Monoid a => a
mempty IntMap IntSet -> Int -> IntSet -> IntMap IntSet
f

pruneReach :: Rooted -> Rooted
pruneReach :: Rooted -> Rooted
pruneReach (Int
r,IntMap IntSet
g) = (Int
r,IntMap IntSet
g2)
  where is :: IntSet
is = (Int -> IntSet) -> Int -> IntSet
reachable
              (IntSet -> (IntSet -> IntSet) -> Maybe IntSet -> IntSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IntSet
forall a. Monoid a => a
mempty IntSet -> IntSet
forall a. a -> a
id
                (Maybe IntSet -> IntSet) -> (Int -> Maybe IntSet) -> Int -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IntMap IntSet -> Maybe IntSet)
-> IntMap IntSet -> Int -> Maybe IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup IntMap IntSet
g) (Int -> IntSet) -> Int -> IntSet
forall a b. (a -> b) -> a -> b
$ Int
r
        g2 :: IntMap IntSet
g2 = [(Int, IntSet)] -> IntMap IntSet
forall a. [(Int, a)] -> IntMap a
IM.fromList
            ([(Int, IntSet)] -> IntMap IntSet)
-> (IntMap IntSet -> [(Int, IntSet)])
-> IntMap IntSet
-> IntMap IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, IntSet) -> (Int, IntSet))
-> [(Int, IntSet)] -> [(Int, IntSet)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IntSet -> IntSet) -> (Int, IntSet) -> (Int, IntSet)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Int -> Bool) -> IntSet -> IntSet
IS.filter (Int -> IntSet -> Bool
`IS.member`IntSet
is)))
            ([(Int, IntSet)] -> [(Int, IntSet)])
-> (IntMap IntSet -> [(Int, IntSet)])
-> IntMap IntSet
-> [(Int, IntSet)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, IntSet) -> Bool) -> [(Int, IntSet)] -> [(Int, IntSet)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> IntSet -> Bool
`IS.member`IntSet
is) (Int -> Bool) -> ((Int, IntSet) -> Int) -> (Int, IntSet) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, IntSet) -> Int
forall a b. (a, b) -> a
fst)
            ([(Int, IntSet)] -> [(Int, IntSet)])
-> (IntMap IntSet -> [(Int, IntSet)])
-> IntMap IntSet
-> [(Int, IntSet)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap IntSet -> [(Int, IntSet)]
forall a. IntMap a -> [(Int, a)]
IM.toList (IntMap IntSet -> IntMap IntSet) -> IntMap IntSet -> IntMap IntSet
forall a b. (a -> b) -> a -> b
$ IntMap IntSet
g

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

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

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

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

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

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

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

-- collect :: (Ord b) => (c -> c -> c)

--         -> (a -> b) -> (a -> c) -> [a] -> Map b c

-- collect (<>) f g

--   = foldl' (\m a -> SM.insertWith (<>)

--                                   (f a)

--                                   (g a) m) mempty


-- (renamed, old -> new)

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

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


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

-- get = S (\k s -> k s s)

gets :: (s -> a) -> S z s a
gets :: forall s a z. (s -> a) -> S z s a
gets s -> a
f = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k s
s -> a -> s -> ST z o
k (s -> a
f s
s) s
s)
-- set :: s -> S z s ()

-- set s = S (\k _ -> k () s)

modify :: (s -> s) -> S z s ()
modify :: forall s z. (s -> s) -> S z s ()
modify s -> s
f = (forall o. (() -> s -> ST z o) -> s -> ST z o) -> S z s ()
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\() -> s -> ST z o
k -> () -> s -> ST z o
k () (s -> ST z o) -> (s -> s) -> s -> ST z o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
f)
-- runS :: S z s a -> s -> ST z (a, s)

-- runS (S g) = g (\a s -> return (a,s))

evalS :: S z s a -> s -> ST z a
evalS :: forall z s a. S z s a -> s -> ST z a
evalS (S forall o. (a -> s -> ST z o) -> s -> ST z o
g) = (a -> s -> ST z a) -> s -> ST z a
forall o. (a -> s -> ST z o) -> s -> ST z o
g ((a -> ST z a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ST z a) -> (s -> a) -> s -> ST z a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((s -> a) -> s -> ST z a) -> (a -> s -> a) -> a -> s -> ST z a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> s -> a
forall a b. a -> b -> a
const)
-- execS :: S z s a -> s -> ST z s

-- execS (S g) = g ((return .) . flip const)

st :: ST z a -> S z s a
st :: forall z a s. ST z a -> S z s a
st ST z a
m = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k s
s-> do
  a
a <- ST z a
m
  a -> s -> ST z o
k a
a s
s)
store :: (MArray (A z) a (ST z))
      => (s -> Arr z a) -> Int -> a -> S z s ()
store :: forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store s -> Arr z a
f Int
i a
x = do
  Arr z a
a <- (s -> Arr z a) -> S z s (Arr z a)
forall s a z. (s -> a) -> S z s a
gets s -> Arr z a
f
  ST z () -> S z s ()
forall z a s. ST z a -> S z s a
st ((Arr z a
aArr z a -> a -> Int -> ST z ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.=a
x) Int
i)
fetch :: (MArray (A z) a (ST z))
      => (s -> Arr z a) -> Int -> S z s a
fetch :: forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch s -> Arr z a
f Int
i = do
  Arr z a
a <- (s -> Arr z a) -> S z s (Arr z a)
forall s a z. (s -> a) -> S z s a
gets s -> Arr z a
f
  ST z a -> S z s a
forall z a s. ST z a -> S z s a
st (Arr z a
aArr z a -> Int -> ST z a
forall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!:Int
i)