{-# LANGUAGE Strict #-}

{- |
  Module      :  GHC.CmmToAsm.CFG.Dominators
  Copyright   :  (c) Matt Morrow 2009
  License     :  BSD3
  Maintainer  :  <klebinger.andreas@gmx.at>
  Stability   :  stable
  Portability :  portable

  The Lengauer-Tarjan graph dominators algorithm.

    \[1\] Lengauer, Tarjan,
      /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979.

    \[2\] Muchnick,
      /Advanced Compiler Design and Implementation/, 1997.

    \[3\] Brisk, Sarrafzadeh,
      /Interference CGraphs for Procedures in Static Single/
      /Information Form are Interval CGraphs/, 2007.

 * Strictness

 Unless stated otherwise all exposed functions might fully evaluate their input
 but are not guaranteed to do so.

-}

module GHC.CmmToAsm.CFG.Dominators (
   Node,Path,Edge
  ,Graph,Rooted
  ,idom,ipdom
  ,domTree,pdomTree
  ,dom,pdom
  ,pddfs,rpddfs
  ,fromAdj,fromEdges
  ,toAdj,toEdges
  ,asTree,asCGraph
  ,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
  (unsafeNewArray_
  ,unsafeWrite,unsafeRead)
import GHC.Data.Word64Set (Word64Set)
import qualified GHC.Data.Word64Set as WS
import GHC.Data.Word64Map (Word64Map)
import qualified GHC.Data.Word64Map as WM
import Data.Word

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

-- Compacted nodes; these can be stored in contiguous arrays
type CNode       = Int
type CGraph      = IntMap IntSet

type Node     = Word64
type Path     = [Node]
type Edge     = (Node, Node)
type Graph    = Word64Map Word64Set
type Rooted   = (Node, Graph)

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

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

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

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

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

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

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

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

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

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

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

type Dom s a = S s (Env s) a
type NodeSet    = Word64Set
type NodeMap a  = Word64Map a
data Env s = Env
  {forall s. Env s -> CGraph
succE      :: !CGraph
  ,forall s. Env s -> CGraph
predE      :: !CGraph
  ,forall s. Env s -> CGraph
bucketE    :: !CGraph
  ,forall s. Env s -> Int
dfsE       :: {-# UNPACK #-}!Int
  ,forall s. Env s -> Int
zeroE      :: {-# UNPACK #-}!CNode
  ,forall s. Env s -> Int
rootE      :: {-# UNPACK #-}!CNode
  ,forall s. Env s -> Arr s Int
labelE     :: {-# UNPACK #-}!(Arr s CNode)
  ,forall s. Env s -> Arr s Int
parentE    :: {-# UNPACK #-}!(Arr s CNode)
  ,forall s. Env s -> Arr s Int
ancestorE  :: {-# UNPACK #-}!(Arr s CNode)
  ,forall s. Env s -> Arr s Int
childE     :: {-# UNPACK #-}!(Arr s CNode)
  ,forall s. Env s -> Arr s Int
ndfsE      :: {-# UNPACK #-}!(Arr s CNode)
  ,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 CNode)
  ,forall s. Env s -> Arr s Node
rnE        :: {-# UNPACK #-}!(Arr s Node)}

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

idomM :: Dom s [(Node,Node)]
idomM :: forall s. Dom s [(Node, Node)]
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
  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
  forM_ [n,n-1..1] (\Int
i-> do
    w <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
ndfsM Int
i
    ps <- predsM w
    forM_ ps (\Int
v-> do
      sw <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
sdnoM Int
w
      u <- eval v
      su <- sdnoM u
      when (su < sw)
        (store sdnoE w su))
    z <- ndfsM =<< sdnoM w
    modify(\Env s
e->Env s
e{bucketE=IM.adjust
                      (w`IS.insert`)
                      z (bucketE e)})
    pw <- parentM w
    link pw w
    bps <- bucketM pw
    forM_ bps (\Int
v-> do
      u <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
eval Int
v
      su <- sdnoM u
      sv <- sdnoM v
      let 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
      store domE v dv))
  forM_ [1..n] (\Int
i-> do
    w <- Int -> S s (Env s) Int
forall s. Int -> Dom s Int
ndfsM Int
i
    j <- sdnoM w
    z <- ndfsM j
    dw <- domM w
    when (dw /= z)
      (do ddw <- domM dw
          store domE w ddw))
  fromEnv

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

eval :: CNode -> Dom s CNode
eval :: forall s. Int -> Dom s Int
eval Int
v = do
  n0 <- Dom s Int
forall s. Dom s Int
zeroM
  a  <- ancestorM v
  case a==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
      a   <- Int -> Dom s Int
forall s. Int -> Dom s Int
ancestorM Int
v
      l   <- labelM v
      la  <- labelM a
      sl  <- sdnoM l
      sla <- sdnoM la
      case sl <= 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 :: CNode -> Dom s ()
compress :: forall s. Int -> Dom s ()
compress Int
v = do
  n0  <- Dom s Int
forall s. Dom s Int
zeroM
  a   <- ancestorM v
  aa  <- ancestorM a
  when (aa /= n0) (do
    compress a
    a   <- ancestorM v
    aa  <- ancestorM a
    l   <- labelM v
    la  <- labelM a
    sl  <- sdnoM l
    sla <- sdnoM la
    when (sla < sl)
      (store labelE v la)
    store ancestorE v aa)

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

link :: CNode -> CNode -> Dom s ()
link :: forall s. Int -> Int -> Dom s ()
link Int
v Int
w = do
  n0  <- Dom s Int
forall s. Dom s Int
zeroM
  lw  <- labelM w
  slw <- sdnoM lw
  let balance Int
s = do
        c   <- Int -> Dom s Int
forall s. Int -> Dom s Int
childM Int
s
        lc  <- labelM c
        slc <- sdnoM lc
        case slw < slc 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
            zs  <- Int -> Dom s Int
forall s. Int -> Dom s Int
sizeM Int
s
            zc  <- sizeM c
            cc  <- childM c
            zcc <- sizeM cc
            case 2*zc <= zs+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 -> Dom 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 -> Dom s Int
balance Int
c
  s   <- balance w
  lw  <- labelM w
  zw  <- sizeM w
  store labelE s lw
  store sizeE v . (+zw) =<< sizeM v
  let follow Int
s =
        Bool -> S s (Env s) () -> S s (Env s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n0) (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
s Int
v
          Int -> S s (Env s) ()
follow (Int -> S s (Env s) ()) -> Dom s Int -> S s (Env s) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Dom s Int
forall s. Int -> Dom s Int
childM Int
s)
  zv  <- sizeM v
  follow =<< case zv < 2*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
                cv <- Int -> Dom s Int
forall s. Int -> Dom s Int
childM Int
v
                store childE v s
                return cv

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

dfsDom :: CNode -> Dom s ()
dfsDom :: forall s. Int -> Dom s ()
dfsDom Int
i = do
  _   <- Int -> S s (Env s) ()
forall s. Int -> Dom s ()
go Int
i
  n0  <- zeroM
  r   <- rootM
  store parentE r n0
  where go :: Int -> S s (Env s) ()
go Int
i = do
          n <- Dom s Int
forall s. Dom s Int
nextM
          store dfnE   i n
          store sdnoE  i n
          store ndfsE  n i
          store labelE i i
          ss <- succsM i
          forM_ ss (\Int
j-> do
            s <- Int -> Dom s Int
forall s. Int -> Dom s Int
sdnoM Int
j
            case s==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 (Node
r0,Graph
g0) = do
  -- CGraph renumbered to indices from 1 to |V|
  let (CGraph
g,NodeMap Int
rnmap) = Int -> Graph -> (CGraph, NodeMap Int)
renum Int
1 Graph
g0
      pred :: CGraph
pred      = CGraph -> CGraph
predG CGraph
g -- reverse graph
      root :: Int
root      = NodeMap Int
rnmap NodeMap Int -> Node -> Int
forall a. Word64Map a -> Node -> a
WM.! Node
r0 -- renamed root
      n :: Int
n         = CGraph -> Int
forall a. IntMap a -> Int
IM.size CGraph
g
      ns :: [Int]
ns        = [Int
0..Int
n]
      m :: Int
m         = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1

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

  rna <- Int -> ST s (Arr s Node)
forall s. Int -> ST s (Arr s Node)
newW Int
m
  writes rna (fmap swap
        (WM.toList rnmap))

  doms      <- newI m
  sdno      <- newI m
  size      <- newI m
  parent    <- newI m
  ancestor  <- newI m
  child     <- newI m
  label     <- newI m
  ndfs      <- newI m
  dfn       <- newI m

  -- Initialize all arrays
  forM_ [0..n] (doms.=0)
  forM_ [0..n] (sdno.=0)
  forM_ [1..n] (size.=1)
  forM_ [0..n] (ancestor.=0)
  forM_ [0..n] (child.=0)

  (doms.=root) root
  (size.=0) 0
  (label.=0) 0

  return (Env
    {rnE        = rna
    ,dfsE       = 0
    ,zeroE      = 0
    ,rootE      = root
    ,labelE     = label
    ,parentE    = parent
    ,ancestorE  = ancestor
    ,childE     = child
    ,ndfsE      = ndfs
    ,dfnE       = dfn
    ,sdnoE      = sdno
    ,sizeE      = size
    ,succE      = g
    ,predE      = pred
    ,bucketE    = bucket
    ,domE       = doms})

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

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

zeroM :: Dom s CNode
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 :: CNode -> Dom s CNode
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 CNode
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 :: CNode -> Dom s [CNode]
succsM :: forall s. Int -> Dom s [Int]
succsM Int
i = (Env s -> [Int]) -> S s (Env s) [Int]
forall s a z. (s -> a) -> S z s a
gets (IntSet -> [Int]
IS.toList (IntSet -> [Int]) -> (Env s -> IntSet) -> Env s -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
i) (CGraph -> IntSet) -> (Env s -> CGraph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> CGraph
forall s. Env s -> CGraph
succE)
predsM :: CNode -> Dom s [CNode]
predsM :: forall s. Int -> Dom s [Int]
predsM Int
i = (Env s -> [Int]) -> S s (Env s) [Int]
forall s a z. (s -> a) -> S z s a
gets (IntSet -> [Int]
IS.toList (IntSet -> [Int]) -> (Env s -> IntSet) -> Env s -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
i) (CGraph -> IntSet) -> (Env s -> CGraph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> CGraph
forall s. Env s -> CGraph
predE)
bucketM :: CNode -> Dom s [CNode]
bucketM :: forall s. Int -> Dom s [Int]
bucketM Int
i = (Env s -> [Int]) -> S s (Env s) [Int]
forall s a z. (s -> a) -> S z s a
gets (IntSet -> [Int]
IS.toList (IntSet -> [Int]) -> (Env s -> IntSet) -> Env s -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph -> Int -> IntSet
forall a. Monoid a => IntMap a -> Int -> a
! Int
i) (CGraph -> IntSet) -> (Env s -> CGraph) -> Env s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> CGraph
forall s. Env s -> CGraph
bucketE)
sizeM :: CNode -> 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 :: CNode -> 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 :: CNode -> Dom s Int
-- dfnM = fetch dfnE
ndfsM :: Int -> Dom s CNode
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 :: CNode -> Dom s CNode
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 :: CNode -> Dom s CNode
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 :: CNode -> Dom s CNode
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 :: CNode -> Dom s CNode
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
  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
  let n' = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
  modify(\Env s
e->Env s
e{dfsE=n'})
  return 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
  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
  return $! o

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

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

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

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)


(!) :: 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 :: [(Node, Path)] -> Graph
fromAdj = [(Node, Word64Set)] -> Graph
forall a. [(Node, a)] -> Word64Map a
WM.fromList ([(Node, Word64Set)] -> Graph)
-> ([(Node, Path)] -> [(Node, Word64Set)])
-> [(Node, Path)]
-> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Node, Path) -> (Node, Word64Set))
-> [(Node, Path)] -> [(Node, Word64Set)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Path -> Word64Set) -> (Node, Path) -> (Node, Word64Set)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Path -> Word64Set
WS.fromList)

fromEdges :: [Edge] -> Graph
fromEdges :: [(Node, Node)] -> Graph
fromEdges = (Word64Set -> Word64Set -> Word64Set)
-> ((Node, Node) -> Node)
-> ((Node, Node) -> Word64Set)
-> [(Node, Node)]
-> Graph
forall c a.
(c -> c -> c) -> (a -> Node) -> (a -> c) -> [a] -> Word64Map c
collectW Word64Set -> Word64Set -> Word64Set
WS.union (Node, Node) -> Node
forall a b. (a, b) -> a
fst (Node -> Word64Set
WS.singleton (Node -> Word64Set)
-> ((Node, Node) -> Node) -> (Node, Node) -> Word64Set
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, Node) -> Node
forall a b. (a, b) -> b
snd)

toAdj :: Graph -> [(Node, [Node])]
toAdj :: Graph -> [(Node, Path)]
toAdj = ((Node, Word64Set) -> (Node, Path))
-> [(Node, Word64Set)] -> [(Node, Path)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Word64Set -> Path) -> (Node, Word64Set) -> (Node, Path)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Word64Set -> Path
WS.toList) ([(Node, Word64Set)] -> [(Node, Path)])
-> (Graph -> [(Node, Word64Set)]) -> Graph -> [(Node, Path)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [(Node, Word64Set)]
forall a. Word64Map a -> [(Node, a)]
WM.toList

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

predG :: CGraph -> CGraph
predG :: CGraph -> CGraph
predG CGraph
g = (IntSet -> IntSet -> IntSet) -> CGraph -> CGraph -> CGraph
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntSet -> IntSet -> IntSet
IS.union (CGraph -> CGraph
go CGraph
g) CGraph
g0
  where g0 :: CGraph
g0 = (IntSet -> IntSet) -> CGraph -> CGraph
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) CGraph
g
        go :: CGraph -> CGraph
go = ((Int -> IntSet -> CGraph -> CGraph) -> CGraph -> CGraph -> CGraph)
-> CGraph
-> (Int -> IntSet -> CGraph -> CGraph)
-> CGraph
-> CGraph
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> IntSet -> CGraph -> CGraph) -> CGraph -> CGraph -> CGraph
forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey CGraph
forall a. Monoid a => a
mempty (\Int
i IntSet
a CGraph
m ->
                (CGraph -> Int -> CGraph) -> CGraph -> [Int] -> CGraph
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\CGraph
m Int
p -> (IntSet -> IntSet -> IntSet) -> Int -> IntSet -> CGraph -> CGraph
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) CGraph
m)
                        CGraph
m
                       (IntSet -> [Int]
IS.toList IntSet
a))

predGW :: Graph -> Graph
predGW :: Graph -> Graph
predGW Graph
g = (Word64Set -> Word64Set -> Word64Set) -> Graph -> Graph -> Graph
forall a.
(a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a
WM.unionWith Word64Set -> Word64Set -> Word64Set
WS.union (Graph -> Graph
go Graph
g) Graph
g0
  where g0 :: Graph
g0 = (Word64Set -> Word64Set) -> Graph -> Graph
forall a b. (a -> b) -> Word64Map a -> Word64Map b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64Set -> Word64Set -> Word64Set
forall a b. a -> b -> a
const Word64Set
forall a. Monoid a => a
mempty) Graph
g
        go :: Graph -> Graph
go = ((Node -> Word64Set -> Graph -> Graph) -> Graph -> Graph -> Graph)
-> Graph -> (Node -> Word64Set -> Graph -> Graph) -> Graph -> Graph
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Node -> Word64Set -> Graph -> Graph) -> Graph -> Graph -> Graph
forall a b. (Node -> a -> b -> b) -> b -> Word64Map a -> b
WM.foldrWithKey Graph
forall a. Monoid a => a
mempty (\Node
i Word64Set
a Graph
m ->
                (Graph -> Node -> 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 Node
p -> (Word64Set -> Word64Set -> Word64Set)
-> Node -> Word64Set -> Graph -> Graph
forall a. (a -> a -> a) -> Node -> a -> Word64Map a -> Word64Map a
WM.insertWith Word64Set -> Word64Set -> Word64Set
forall a. Monoid a => a -> a -> a
mappend Node
p
                                      (Node -> Word64Set
WS.singleton Node
i) Graph
m)
                        Graph
m
                       (Word64Set -> Path
WS.toList Word64Set
a))

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

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

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

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

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

asTree :: Rooted -> Tree Node
asTree :: Rooted -> Tree Node
asTree (Node
r,Graph
g) = let go :: Node -> Tree Node
go Node
a = Node -> [Tree Node] -> Tree Node
forall a. a -> [Tree a] -> Tree a
Node Node
a ((Node -> Tree Node) -> Path -> [Tree Node]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node -> Tree Node
go ((Word64Set -> Path
WS.toList (Word64Set -> Path) -> (Node -> Word64Set) -> Node -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Word64Set
f) Node
a))
                   f :: Node -> Word64Set
f = (Graph
g Graph -> Node -> Word64Set
forall {b}. Monoid b => Word64Map b -> Node -> b
!)
            in Node -> Tree Node
go Node
r
  where ! :: Word64Map b -> Node -> b
(!) Word64Map b
g Node
n = b -> (b -> b) -> Maybe b -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
forall a. Monoid a => a
mempty b -> b
forall a. a -> a
id (Node -> Word64Map b -> Maybe b
forall a. Node -> Word64Map a -> Maybe a
WM.lookup Node
n Word64Map b
g)


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

collectW :: (c -> c -> c)
        -> (a -> Node) -> (a -> c) -> [a] -> Word64Map c
collectW :: forall c a.
(c -> c -> c) -> (a -> Node) -> (a -> c) -> [a] -> Word64Map c
collectW c -> c -> c
(<>) a -> Node
f a -> c
g
  = (Word64Map c -> a -> Word64Map c)
-> Word64Map c -> [a] -> Word64Map c
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Word64Map c
m a
a -> (c -> c -> c) -> Node -> c -> Word64Map c -> Word64Map c
forall a. (a -> a -> a) -> Node -> a -> Word64Map a -> Word64Map a
WM.insertWith c -> c -> c
(<>)
                                  (a -> Node
f a
a)
                                  (a -> c
g a
a) Word64Map c
m) Word64Map c
forall a. Monoid a => a
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 -> (CGraph, NodeMap CNode)
renum :: Int -> Graph -> (CGraph, NodeMap Int)
renum Int
from = (\(Int
_,NodeMap Int
m,CGraph
g)->(CGraph
g,NodeMap Int
m))
  ((Int, NodeMap Int, CGraph) -> (CGraph, NodeMap Int))
-> (Graph -> (Int, NodeMap Int, CGraph))
-> Graph
-> (CGraph, NodeMap Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node
 -> Word64Set
 -> (Int, NodeMap Int, CGraph)
 -> (Int, NodeMap Int, CGraph))
-> (Int, NodeMap Int, CGraph)
-> Graph
-> (Int, NodeMap Int, CGraph)
forall a b. (Node -> a -> b -> b) -> b -> Word64Map a -> b
WM.foldrWithKey
      (\Node
i Word64Set
ss (!Int
n,!NodeMap Int
env,!CGraph
new)->
          let (Int
j,Int
n2,NodeMap Int
env2) = Int -> NodeMap Int -> Node -> (Int, Int, NodeMap Int)
go Int
n NodeMap Int
env Node
i
              (Int
n3,NodeMap Int
env3,IntSet
ss2) = (Node -> (Int, NodeMap Int, IntSet) -> (Int, NodeMap Int, IntSet))
-> (Int, NodeMap Int, IntSet)
-> Word64Set
-> (Int, NodeMap Int, IntSet)
forall b. (Node -> b -> b) -> b -> Word64Set -> b
WS.fold
                (\Node
k (!Int
n,!NodeMap Int
env,!IntSet
new)->
                    case Int -> NodeMap Int -> Node -> (Int, Int, NodeMap Int)
go Int
n NodeMap Int
env Node
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) Word64Set
ss
              new2 :: CGraph
new2 = (IntSet -> IntSet -> IntSet) -> Int -> IntSet -> CGraph -> CGraph
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
IS.union Int
j IntSet
ss2 CGraph
new
          in (Int
n3,NodeMap Int
env3,CGraph
new2)) (Int
from,NodeMap Int
forall a. Monoid a => a
mempty,CGraph
forall a. Monoid a => a
mempty)
  where go :: Int
           -> NodeMap CNode
           -> Node
           -> (CNode,Int,NodeMap CNode)
        go :: Int -> NodeMap Int -> Node -> (Int, Int, NodeMap Int)
go !Int
n !NodeMap Int
env Node
i =
          case Node -> NodeMap Int -> Maybe Int
forall a. Node -> Word64Map a -> Maybe a
WM.lookup Node
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,Node -> Int -> NodeMap Int -> NodeMap Int
forall a. Node -> a -> Word64Map a -> Word64Map a
WM.insert Node
i Int
n NodeMap Int
env)

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

-- Nothing better than reinventing 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}
  deriving ((forall a b. (a -> b) -> S z s a -> S z s b)
-> (forall a b. a -> S z s b -> S z s a) -> Functor (S z s)
forall a b. a -> S z s b -> S z s a
forall a b. (a -> b) -> S z s a -> S z s b
forall z s a b. a -> S z s b -> S z s a
forall z s a b. (a -> b) -> S z s a -> S z s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall z s a b. (a -> b) -> S z s a -> S z s b
fmap :: forall a b. (a -> b) -> S z s a -> S z s b
$c<$ :: forall z s a b. a -> S z s b -> S z s a
<$ :: forall a b. a -> S z s b -> S z s a
Functor)
instance Monad (S z s) where
  return :: forall a. a -> S z s a
return = a -> S z s a
forall a. a -> S z s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  S forall o. (a -> s -> ST z o) -> s -> ST z o
g >>= :: forall a b. S z s a -> (a -> S z s b) -> S z s b
>>= a -> S z s b
f = (forall o. (b -> s -> ST z o) -> s -> ST z o) -> S z s b
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\b -> s -> ST z o
k -> (a -> s -> ST z o) -> s -> ST z o
forall o. (a -> s -> ST z o) -> s -> ST z o
g (\a
a -> S z s b -> forall o. (b -> s -> ST z o) -> s -> ST z o
forall z s a.
S z s a -> forall o. (a -> s -> ST z o) -> s -> ST z o
unS (a -> S z s b
f a
a) b -> s -> ST z o
k))
instance Applicative (S z s) where
  pure :: forall a. a -> S z s a
pure a
a = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k -> a -> s -> ST z o
k a
a)
  <*> :: forall a b. S z s (a -> b) -> S z s a -> S z s b
(<*>) = S z s (a -> b) -> S z s a -> S z s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
-- get :: S z s s
-- get = S (\k s -> k s s)
gets :: (s -> a) -> S z s a
gets :: forall s a z. (s -> a) -> S z s a
gets s -> a
f = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k s
s -> a -> s -> ST z o
k (s -> a
f s
s) s
s)
-- set :: s -> S z s ()
-- set s = S (\k _ -> k () s)
modify :: (s -> s) -> S z s ()
modify :: forall s z. (s -> s) -> S z s ()
modify s -> s
f = (forall o. (() -> s -> ST z o) -> s -> ST z o) -> S z s ()
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\() -> s -> ST z o
k -> () -> s -> ST z o
k () (s -> ST z o) -> (s -> s) -> s -> ST z o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
f)
-- runS :: S z s a -> s -> ST z (a, s)
-- runS (S g) = g (\a s -> return (a,s))
evalS :: S z s a -> s -> ST z a
evalS :: forall z s a. S z s a -> s -> ST z a
evalS (S forall o. (a -> s -> ST z o) -> s -> ST z o
g) = (a -> s -> ST z a) -> s -> ST z a
forall o. (a -> s -> ST z o) -> s -> ST z o
g ((a -> ST z a
forall a. a -> ST z a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ST z a) -> (s -> a) -> s -> ST z a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((s -> a) -> s -> ST z a) -> (a -> s -> a) -> a -> s -> ST z a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> s -> a
forall a b. a -> b -> a
const)
-- execS :: S z s a -> s -> ST z s
-- execS (S g) = g ((return .) . flip const)
st :: ST z a -> S z s a
st :: forall z a s. ST z a -> S z s a
st ST z a
m = (forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
forall z s a.
(forall o. (a -> s -> ST z o) -> s -> ST z o) -> S z s a
S (\a -> s -> ST z o
k s
s-> do
  a <- ST z a
m
  k a 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
  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 ((a.=x) 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
  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 (a!:i)