{-# LANGUAGE CPP #-}
{-# LANGUAGE Strict #-}
-- SPDX-FileCopyrightText: 2009 Matt Morrow <klebinger.andreas@gmx.at>
--
-- SPDX-License-Identifier: BSD-3-Clause
{-# OPTIONS_GHC -Wno-name-shadowing #-}

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

import Control.Monad
import Control.Monad.ST.Strict
import Data.Array.Base
  ( unsafeNewArray_,
    unsafeRead,
    unsafeWrite,
  )
import Data.Array.ST
import Data.IntMap (IntMap)
import Data.IntMap.Strict qualified as IM
import Data.IntSet (IntSet)
import Data.IntSet qualified as IS
import Data.Maybe
import Data.Tree
import Data.Tuple (swap)

-- Since GHC 9.10.1, Prelude exports foldl' before that we need 'Data.Foldable'.
--
-- See: https://gitlab.haskell.org/ghc/ghc/-/commit/f1ec362817baa5d440a9f2b3a8b17e5513538119
#if !MIN_VERSION_base(4,20,0)
import Data.Foldable (foldl')
#endif

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

type Node = Int

type Path = [Node]

type Edge = (Node, Node)

type Graph = IntMap IntSet

type Rooted = (Node, Graph)

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

-- | /Dominators/.
-- Complexity as for @idom@
dom :: Rooted -> [(Node, Path)]
dom :: Rooted -> [(Int, Path)]
dom = Tree Int -> [(Int, Path)]
forall a. Tree a -> [(a, [a])]
ancestors (Tree Int -> [(Int, Path)])
-> (Rooted -> Tree Int) -> Rooted -> [(Int, Path)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Int
domTree

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

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

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

-- | /Immediate dominators/.
-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is
-- \"a functional inverse of Ackermann's function\".
--
-- This Complexity bound assumes /O(1)/ indexing. Since we're
-- using @IntMap@, it has an additional /lg |V|/ factor
-- somewhere in there. I'm not sure where.
idom :: Rooted -> [(Node, Node)]
idom :: Rooted -> [(Int, Int)]
idom Rooted
rg = (forall s. ST s [(Int, Int)]) -> [(Int, Int)]
forall a. (forall s. ST s a) -> a
runST (S s (Env s) [(Int, Int)] -> Env s -> ST s [(Int, Int)]
forall z s a. S z s a -> s -> ST z a
evalS S s (Env s) [(Int, Int)]
forall s. Dom s [(Int, Int)]
idomM (Env s -> ST s [(Int, Int)]) -> ST s (Env s) -> ST s [(Int, Int)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Rooted -> ST s (Env s)
forall s. Rooted -> ST s (Env s)
initEnv (Rooted -> Rooted
pruneReach Rooted
rg))

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

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

-- | /Post-dominated depth-first search/.
pddfs :: Rooted -> [Node]
pddfs :: Rooted -> Path
pddfs = Path -> Path
forall a. [a] -> [a]
reverse (Path -> Path) -> (Rooted -> Path) -> Rooted -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Path
rpddfs

-- | /Reverse post-dominated depth-first search/.
rpddfs :: Rooted -> [Node]
rpddfs :: Rooted -> Path
rpddfs = [Path] -> Path
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Path] -> Path) -> (Rooted -> [Path]) -> Rooted -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Int -> [Path]
forall a. Tree a -> [[a]]
levels (Tree Int -> [Path]) -> (Rooted -> Tree Int) -> Rooted -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rooted -> Tree Int
pdomTree

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

type Dom s a = S s (Env s) a

type NodeSet = IntSet

type NodeMap a = IntMap a

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

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

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

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

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

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

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

link :: Node -> Node -> Dom s ()
link :: forall s. Int -> Int -> Dom s ()
link Int
v Int
w = do
  Int
n0 <- Dom s Int
forall s. Dom s Int
zeroM
  Int
lw <- Int -> Dom s Int
forall s. Int -> Dom s Int
labelM Int
w
  Int
slw <- Int -> Dom s Int
forall s. Int -> Dom s Int
sdnoM Int
lw
  let balance :: Int -> S s (Env s) Int
balance Int
s = do
        Int
c <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
childM Int
s
        Int
lc <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
labelM Int
c
        Int
slc <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sdnoM Int
lc
        case Int
slw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
slc of
          Bool
False -> Int -> S s (Env s) Int
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
s
          Bool
True -> do
            Int
zs <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sizeM Int
s
            Int
zc <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sizeM Int
c
            Int
cc <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
childM Int
c
            Int
zcc <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sizeM Int
cc
            case Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
zc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
zs Int -> 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
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
zw of
    Bool
False -> Int -> Dom s Int
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
s
    Bool
True -> do
      Int
cv <- Int -> Dom s Int
forall s. Int -> Dom s Int
childM Int
v
      (Env s -> Arr s Int) -> Int -> Int -> Dom s ()
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> a -> S z s ()
store Env s -> Arr s Int
forall s. Env s -> Arr s Int
childE Int
v Int
s
      Int -> Dom s Int
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
cv

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

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

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

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

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

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

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

  -- Initialize all arrays
  Path -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
n] (Arr s Int
doms Arr 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
sdno Arr 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
size Arr 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
ancestor Arr 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
child Arr 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
doms Arr s Int -> Int -> Int -> ST s ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.= Int
root) Int
root
  (Arr s Int
size Arr 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
label Arr s Int -> Int -> Int -> ST s ()
forall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
.= Int
0) Int
0

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

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

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

zeroM :: Dom s Node
zeroM :: forall s. Dom s Int
zeroM = (Env s -> Int) -> S s (Env s) Int
forall s a z. (s -> a) -> S z s a
gets Env s -> Int
forall s. Env s -> Int
zeroE

domM :: Node -> Dom s Node
domM :: forall s. Int -> Dom s Int
domM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
domE

rootM :: Dom s Node
rootM :: forall s. Dom s Int
rootM = (Env s -> Int) -> S s (Env s) Int
forall s a z. (s -> a) -> S z s a
gets Env s -> Int
forall s. Env s -> Int
rootE

succsM :: Node -> Dom s [Node]
succsM :: forall s. Int -> Dom s Path
succsM Int
i = (Env s -> Path) -> S s (Env s) Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
i) (Graph -> IntSet) -> (Env s -> Graph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> Graph
forall s. Env s -> Graph
succE)

predsM :: Node -> Dom s [Node]
predsM :: forall s. Int -> Dom s Path
predsM Int
i = (Env s -> Path) -> S s (Env s) Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
i) (Graph -> IntSet) -> (Env s -> Graph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> Graph
forall s. Env s -> Graph
predE)

bucketM :: Node -> Dom s [Node]
bucketM :: forall s. Int -> Dom s Path
bucketM Int
i = (Env s -> Path) -> S s (Env s) Path
forall s a z. (s -> a) -> S z s a
gets (IntSet -> Path
IS.toList (IntSet -> Path) -> (Env s -> IntSet) -> Env s -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
i) (Graph -> IntSet) -> (Env s -> Graph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> Graph
forall s. Env s -> Graph
bucketE)

sizeM :: Node -> Dom s Int
sizeM :: forall s. Int -> Dom s Int
sizeM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
sizeE

sdnoM :: Node -> Dom s Int
sdnoM :: forall s. Int -> Dom s Int
sdnoM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
sdnoE

-- dfnM :: Node -> Dom s Int
-- dfnM = fetch dfnE
ndfsM :: Int -> Dom s Node
ndfsM :: forall s. Int -> Dom s Int
ndfsM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
ndfsE

childM :: Node -> Dom s Node
childM :: forall s. Int -> Dom s Int
childM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
childE

ancestorM :: Node -> Dom s Node
ancestorM :: forall s. Int -> Dom s Int
ancestorM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
ancestorE

parentM :: Node -> Dom s Node
parentM :: forall s. Int -> Dom s Int
parentM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
parentE

labelM :: Node -> Dom s Node
labelM :: forall s. Int -> Dom s Int
labelM = (Env s -> Arr s Int) -> Int -> S s (Env s) Int
forall z a s.
MArray (A z) a (ST z) =>
(s -> Arr z a) -> Int -> S z s a
fetch Env s -> Arr s Int
forall s. Env s -> Arr s Int
labelE

nextM :: Dom s Int
nextM :: forall s. Dom s Int
nextM = do
  Int
n <- (Env s -> Int) -> Dom s Int
forall s a z. (s -> a) -> S z s a
gets Env s -> Int
forall s. Env s -> Int
dfsE
  let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  (Env s -> Env s) -> S s (Env s) ()
forall s z. (s -> s) -> S z s ()
modify (\Env s
e -> Env s
e {dfsE = n'})
  Int -> Dom s Int
forall a. a -> S s (Env s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'

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

type A = STUArray

type Arr s a = A s Int a

infixl 9 !:

infixr 2 .=

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

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

new ::
  (MArray (A s) a (ST s)) =>
  Int -> ST s (Arr s a)
new :: forall s a. MArray (A s) a (ST s) => Int -> ST s (Arr s a)
new Int
n = (Int, Int) -> ST s (STUArray s Int a)
forall i. Ix i => (i, i) -> ST s (STUArray s i a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
unsafeNewArray_ (Int
0, Int
n Int -> 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
a Arr 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 -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
forall a. Monoid a => a
mempty (Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
n IntMap a
g)

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

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

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

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

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

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

pruneReach :: Rooted -> Rooted
pruneReach :: Rooted -> Rooted
pruneReach (Int
r, Graph
g) = (Int
r, Graph
g2)
  where
    is :: IntSet
is =
      (Int -> IntSet) -> Int -> IntSet
reachable
        ( IntSet -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
fromMaybe IntSet
forall a. Monoid a => a
mempty
            (Maybe IntSet -> IntSet) -> (Int -> Maybe IntSet) -> Int -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Graph -> Maybe IntSet) -> Graph -> Int -> Maybe IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Graph -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup Graph
g
        )
        Int
r
    g2 :: Graph
g2 =
      (IntSet -> IntSet) -> Graph -> Graph
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map ((Int -> Bool) -> IntSet -> IntSet
IS.filter (Int -> IntSet -> Bool
`IS.member` IntSet
is))
        (Graph -> Graph) -> (Graph -> Graph) -> Graph -> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IntSet -> Bool) -> Graph -> Graph
forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IM.filterWithKey (\Int
node IntSet
_targets -> Int -> IntSet -> Bool
IS.member Int
node IntSet
is)
        (Graph -> Graph) -> Graph -> Graph
forall a b. (a -> b) -> a -> b
$ Graph
g

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

parents :: Tree a -> [(a, a)]
parents :: forall a. Tree a -> [(a, a)]
parents (Node a
i [Tree a]
xs) =
  a -> [Tree a] -> [(a, a)]
forall {f :: * -> *} {t} {b}.
Functor f =>
t -> f (Tree b) -> f (b, t)
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 :: t -> f (Tree b) -> f (b, t)
p t
i = (Tree b -> (b, t)) -> f (Tree b) -> f (b, t)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,t
i) (b -> (b, t)) -> (Tree b -> b) -> Tree b -> (b, t)
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
i b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
acc
       in [b] -> [Tree b] -> [(b, [b])]
forall {f :: * -> *} {t} {b}.
Functor f =>
t -> f (Tree b) -> f (b, t)
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 :: t -> f (Tree b) -> f (b, t)
p t
is = (Tree b -> (b, t)) -> f (Tree b) -> f (b, t)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,t
is) (b -> (b, t)) -> (Tree b -> b) -> Tree b -> (b, t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree b -> b
forall a. Tree a -> a
rootLabel)

asGraph :: Tree Node -> Rooted
asGraph :: Tree Int -> Rooted
asGraph t :: Tree Int
t@(Node Int
a [Tree Int]
_) = let g :: [(Int, Path)]
g = Tree Int -> [(Int, Path)]
forall a. Tree a -> [(a, [a])]
go Tree Int
t in (Int
a, [(Int, Path)] -> Graph
fromAdj [(Int, Path)]
g)
  where
    go :: Tree a -> [(a, [a])]
go (Node a
a [Tree a]
ts) =
      let as :: [a]
as = (((a, [Tree a]) -> a) -> [(a, [Tree a])] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (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
. (Tree a -> (a, [Tree a])) -> [Tree a] -> [(a, [Tree a])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree a -> (a, [Tree a])
forall a. Tree a -> (a, [Tree a])
tip) [Tree a]
ts
       in (a
a, [a]
as) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: (Tree a -> [(a, [a])]) -> [Tree a] -> [(a, [a])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [(a, [a])]
go [Tree a]
ts

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

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

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

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

-- | renum n g: Rename all nodes
--
-- Gives nodes sequential names starting at n.
-- Returns the new graph and a mapping.
-- (renamed, old -> new)
renum :: Int -> Graph -> (Graph, NodeMap Node)
renum :: Int -> Graph -> (Graph, NodeMap Int)
renum Int
from =
  (\(Int
_, NodeMap Int
m, Graph
g) -> (Graph
g, NodeMap Int
m))
    ((Int, NodeMap Int, Graph) -> (Graph, NodeMap Int))
-> (Graph -> (Int, NodeMap Int, Graph))
-> Graph
-> (Graph, NodeMap Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
 -> IntSet
 -> (Int, NodeMap Int, Graph)
 -> (Int, NodeMap Int, Graph))
-> (Int, NodeMap Int, Graph) -> Graph -> (Int, NodeMap Int, Graph)
forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey
      ( \Int
i IntSet
ss (!Int
n, !NodeMap Int
env, !Graph
new) ->
          let (Int
j, Int
n2, NodeMap Int
env2) = Int -> NodeMap Int -> Int -> (Int, Int, NodeMap Int)
go Int
n NodeMap Int
env Int
i
              (Int
n3, NodeMap Int
env3, IntSet
ss2) =
                (Int -> (Int, NodeMap Int, IntSet) -> (Int, NodeMap Int, IntSet))
-> (Int, NodeMap Int, IntSet)
-> IntSet
-> (Int, NodeMap Int, IntSet)
forall b. (Int -> b -> b) -> b -> IntSet -> b
IS.fold
                  ( \Int
k (!Int
n, !NodeMap Int
env, !IntSet
new) ->
                      case Int -> NodeMap Int -> Int -> (Int, Int, NodeMap Int)
go Int
n NodeMap Int
env Int
k of
                        (Int
l, Int
n2, NodeMap Int
env2) -> (Int
n2, NodeMap Int
env2, Int
l Int -> IntSet -> IntSet
`IS.insert` IntSet
new)
                  )
                  (Int
n2, NodeMap Int
env2, IntSet
forall a. Monoid a => a
mempty)
                  IntSet
ss
              new2 :: Graph
new2 = (IntSet -> IntSet -> IntSet) -> Int -> IntSet -> Graph -> Graph
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
IS.union Int
j IntSet
ss2 Graph
new
           in (Int
n3, NodeMap Int
env3, Graph
new2)
      )
      (Int
from, NodeMap Int
forall a. Monoid a => a
mempty, Graph
forall a. Monoid a => a
mempty)
  where
    go ::
      Int ->
      NodeMap Node ->
      Node ->
      (Node, Int, NodeMap Node)
    go :: Int -> NodeMap Int -> Int -> (Int, Int, NodeMap Int)
go !Int
n !NodeMap Int
env Int
i =
      case Int -> NodeMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i NodeMap Int
env of
        Just Int
j -> (Int
j, Int
n, NodeMap Int
env)
        Maybe Int
Nothing -> (Int
n, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Int -> NodeMap Int -> NodeMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Int
n NodeMap Int
env)

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

-- Nothing better than reinvinting the state monad.
newtype S z s a = S {forall z s a.
S z s a -> forall o. (a -> s -> ST z o) -> s -> ST z o
unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}

instance Functor (S z s) where
  fmap :: forall a b. (a -> b) -> S z s a -> S z s b
fmap a -> b
f (S forall o. (a -> s -> ST z o) -> s -> ST z o
g) = (forall o. (b -> s -> ST z o) -> s -> ST z o) -> S z s b
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\b -> s -> ST z o
k -> (a -> s -> ST z o) -> s -> ST z o
forall o. (a -> s -> ST z o) -> s -> ST z o
g (b -> s -> ST z o
k (b -> s -> ST z o) -> (a -> b) -> a -> s -> ST z o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))

instance Monad (S z s) where
  return :: forall a. a -> S z s a
return = a -> S z s a
forall a. a -> S z s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  S forall o. (a -> s -> ST z o) -> s -> ST z o
g >>= :: forall a b. S z s a -> (a -> S z s b) -> S z s b
>>= a -> S z s b
f = (forall o. (b -> s -> ST z o) -> s -> ST z o) -> S z s b
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\b -> s -> ST z o
k -> (a -> s -> ST z o) -> s -> ST z o
forall o. (a -> s -> ST z o) -> s -> ST z o
g (\a
a -> S z s b -> forall o. (b -> s -> ST z o) -> s -> ST z o
forall z s a.
S z s a -> forall o. (a -> s -> ST z o) -> s -> ST z o
unS (a -> S z s b
f a
a) b -> s -> ST z o
k))

instance Applicative (S z s) where
  pure :: forall a. a -> S z s a
pure a
a = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k -> a -> s -> ST z o
k a
a)
  <*> :: forall a b. S z s (a -> b) -> S z s a -> S z s b
(<*>) = S z s (a -> b) -> S z s a -> S z s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

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

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

-- runS :: S z s a -> s -> ST z (a, s)
-- runS (S g) = g (\a s -> return (a,s))
evalS :: S z s a -> s -> ST z a
evalS :: forall z s a. S z s a -> s -> ST z a
evalS (S forall o. (a -> s -> ST z o) -> s -> ST z o
g) = (a -> s -> ST z a) -> s -> ST z a
forall o. (a -> s -> ST z o) -> s -> ST z o
g ((a -> ST z a
forall a. a -> ST z a
forall (m :: * -> *) a. Monad m => a -> m a
return .) ((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
a Arr 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
a Arr z a -> Int -> ST z a
forall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
!: Int
i)

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