    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE RankNTypes #-}
    {-# 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 Graphs for Procedures in Static Single/
          /Information Form are Interval Graphs/, 2007.

     * Strictness

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

    -}

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

    import GHC.Prelude
    import Data.Bifunctor
    import Data.Tuple (swap)

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

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

    import Data.Array.ST
    import Data.Array.Base
      (unsafeNewArray_
      ,unsafeWrite,unsafeRead)

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

    type Node       = Int
    type Path       = [Node]
    type Edge       = (Node,Node)
    type Graph      = IntMap IntSet
    type Rooted     = (Node, Graph)

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

    -- | /Dominators/.
    -- Complexity as for @idom@
    dom :: Rooted -> [(Node, Path)]
    dom :: Rooted -> [(Int, Path)]
    dom = forall a. Tree a -> [(a, [a])]
    ancestors 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 = forall a. Tree a -> [(a, [a])]
    ancestors 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 = forall a. (a -> Bool) -> [a] -> [a]
    filter ((forall a. Eq a => a -> a -> Bool
    /=Int
    r)forall b c a. (b -> c) -> (a -> b) -> a -> c
    .forall a b. (a, b) -> a
    fst) (Rooted -> [(Int, Int)]
    idom Rooted
    a)
          tg :: Graph
    tg = [(Int, Int)] -> Graph
    fromEdges (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap 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 = forall a. (a -> Bool) -> [a] -> [a]
    filter ((forall a. Eq a => a -> a -> Bool
    /=Int
    r)forall b c a. (b -> c) -> (a -> b) -> a -> c
    .forall a b. (a, b) -> a
    fst) (Rooted -> [(Int, Int)]
    ipdom Rooted
    a)
          tg :: Graph
    tg = [(Int, Int)] -> Graph
    fromEdges (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap 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 a. (forall s. ST s a) -> a
    runST (forall z s a. S z s a -> s -> ST z a
    evalS forall s. Dom s [(Int, Int)]
    idomM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< 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 a. (forall s. ST s a) -> a
    runST (forall z s a. S z s a -> s -> ST z a
    evalS forall s. Dom s [(Int, Int)]
    idomM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< forall s. Rooted -> ST s (Env s)
    initEnv (Rooted -> Rooted
    pruneReach (forall (p :: * -> * -> *) b c a.
    Bifunctor p =>
    (b -> c) -> p a b -> p a c
    second Graph -> Graph
    predG Rooted
    rg)))

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

    -- | /Post-dominated depth-first search/.
    pddfs :: Rooted -> [Node]
    pddfs :: Rooted -> Path
    pddfs = forall a. [a] -> [a]
    reverse 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a. Tree a -> [[a]]
    levels 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
      forall s. Int -> Dom s ()
    dfsDom forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< forall s. Dom s Int
    rootM
      Int
    n <- forall s a z. (s -> a) -> S z s a
    gets forall s. Env s -> Int
    dfsE
      forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [Int
    n,Int
    nforall a. Num a => a -> a -> a
    -Int
    1..Int
    1] (\Int
    i-> do
        Int
    w <- forall s. Int -> Dom s Int
    ndfsM Int
    i
        Path
    ps <- forall s. Int -> Dom s Path
    predsM Int
    w
        forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ Path
    ps (\Int
    v-> do
          Int
    sw <- forall s. Int -> Dom s Int
    sdnoM Int
    w
          Int
    u <- forall s. Int -> Dom s Int
    eval Int
    v
          Int
    su <- forall s. Int -> Dom s Int
    sdnoM Int
    u
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    su forall a. Ord a => a -> a -> Bool
    < Int
    sw)
            (forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    sdnoE Int
    w Int
    su))
        Int
    z <- forall s. Int -> Dom s Int
    ndfsM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< forall s. Int -> Dom s Int
    sdnoM Int
    w
        forall s z. (s -> s) -> S z s ()
    modify(\Env s
    e->Env s
    e{bucketE :: Graph
    bucketE=forall a. (a -> a) -> Int -> IntMap a -> IntMap a
    IM.adjust
                          (Int
    wInt -> IntSet -> IntSet
    `IS.insert`)
                          Int
    z (forall s. Env s -> Graph
    bucketE Env s
    e)})
        Int
    pw <- forall s. Int -> Dom s Int
    parentM Int
    w
        forall s. Int -> Int -> Dom s ()
    link Int
    pw Int
    w
        Path
    bps <- forall s. Int -> Dom s Path
    bucketM Int
    pw
        forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ Path
    bps (\Int
    v-> do
          Int
    u <- forall s. Int -> Dom s Int
    eval Int
    v
          Int
    su <- forall s. Int -> Dom s Int
    sdnoM Int
    u
          Int
    sv <- forall s. Int -> Dom s Int
    sdnoM Int
    v
          let dv :: Int
    dv = case Int
    su forall a. Ord a => a -> a -> Bool
    < Int
    sv of
                    Bool
    True-> Int
    u
                    Bool
    False-> Int
    pw
          forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    domE Int
    v Int
    dv))
      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 <- forall s. Int -> Dom s Int
    ndfsM Int
    i
        Int
    j <- forall s. Int -> Dom s Int
    sdnoM Int
    w
        Int
    z <- forall s. Int -> Dom s Int
    ndfsM Int
    j
        Int
    dw <- forall s. Int -> Dom s Int
    domM Int
    w
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    dw forall a. Eq a => a -> a -> Bool
    /= Int
    z)
          (do Int
    ddw <- forall s. Int -> Dom s Int
    domM Int
    dw
              forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    domE Int
    w Int
    ddw))
      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 <- forall s. Dom s Int
    zeroM
      Int
    a  <- forall s. Int -> Dom s Int
    ancestorM Int
    v
      case Int
    aforall a. Eq a => a -> a -> Bool
    ==Int
    n0 of
        Bool
    True-> forall s. Int -> Dom s Int
    labelM Int
    v
        Bool
    False-> do
          forall s. Int -> Dom s ()
    compress Int
    v
          Int
    a   <- forall s. Int -> Dom s Int
    ancestorM Int
    v
          Int
    l   <- forall s. Int -> Dom s Int
    labelM Int
    v
          Int
    la  <- forall s. Int -> Dom s Int
    labelM Int
    a
          Int
    sl  <- forall s. Int -> Dom s Int
    sdnoM Int
    l
          Int
    sla <- forall s. Int -> Dom s Int
    sdnoM Int
    la
          case Int
    sl forall a. Ord a => a -> a -> Bool
    <= Int
    sla of
            Bool
    True-> forall (m :: * -> *) a. Monad m => a -> m a
    return Int
    l
            Bool
    False-> 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  <- forall s. Dom s Int
    zeroM
      Int
    a   <- forall s. Int -> Dom s Int
    ancestorM Int
    v
      Int
    aa  <- forall s. Int -> Dom s Int
    ancestorM Int
    a
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    aa forall a. Eq a => a -> a -> Bool
    /= Int
    n0) (do
        forall s. Int -> Dom s ()
    compress Int
    a
        Int
    a   <- forall s. Int -> Dom s Int
    ancestorM Int
    v
        Int
    aa  <- forall s. Int -> Dom s Int
    ancestorM Int
    a
        Int
    l   <- forall s. Int -> Dom s Int
    labelM Int
    v
        Int
    la  <- forall s. Int -> Dom s Int
    labelM Int
    a
        Int
    sl  <- forall s. Int -> Dom s Int
    sdnoM Int
    l
        Int
    sla <- forall s. Int -> Dom s Int
    sdnoM Int
    la
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    sla forall a. Ord a => a -> a -> Bool
    < Int
    sl)
          (forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    labelE Int
    v Int
    la)
        forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store 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  <- forall s. Dom s Int
    zeroM
      Int
    lw  <- forall s. Int -> Dom s Int
    labelM Int
    w
      Int
    slw <- forall s. Int -> Dom s Int
    sdnoM Int
    lw
      let balance :: Int -> S s (Env s) Int
    balance Int
    s = do
            Int
    c   <- forall s. Int -> Dom s Int
    childM Int
    s
            Int
    lc  <- forall s. Int -> Dom s Int
    labelM Int
    c
            Int
    slc <- forall s. Int -> Dom s Int
    sdnoM Int
    lc
            case Int
    slw forall a. Ord a => a -> a -> Bool
    < Int
    slc of
              Bool
    False-> forall (m :: * -> *) a. Monad m => a -> m a
    return Int
    s
              Bool
    True-> do
                Int
    zs  <- forall s. Int -> Dom s Int
    sizeM Int
    s
                Int
    zc  <- forall s. Int -> Dom s Int
    sizeM Int
    c
                Int
    cc  <- forall s. Int -> Dom s Int
    childM Int
    c
                Int
    zcc <- forall s. Int -> Dom s Int
    sizeM Int
    cc
                case Int
    2forall a. Num a => a -> a -> a
    *Int
    zc forall a. Ord a => a -> a -> Bool
    <= Int
    zsforall a. Num a => a -> a -> a
    +Int
    zcc of
                  Bool
    True-> do
                    forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    ancestorE Int
    c Int
    s
                    forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    childE Int
    s Int
    cc
                    Int -> S s (Env s) Int
    balance Int
    s
                  Bool
    False-> do
                    forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    sizeE Int
    c Int
    zs
                    forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    ancestorE Int
    s Int
    c
                    Int -> S s (Env s) Int
    balance Int
    c
      Int
    s   <- Int -> S s (Env s) Int
    balance Int
    w
      Int
    lw  <- forall s. Int -> Dom s Int
    labelM Int
    w
      Int
    zw  <- forall s. Int -> Dom s Int
    sizeM Int
    w
      forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    labelE Int
    s Int
    lw
      forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    sizeE Int
    v forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (forall a. Num a => a -> a -> a
    +Int
    zw) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< forall s. Int -> Dom s Int
    sizeM Int
    v
      let follow :: Int -> Dom s ()
    follow Int
    s =
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    s forall a. Eq a => a -> a -> Bool
    /= Int
    n0) (do
              forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    ancestorE Int
    s Int
    v
              Int -> Dom s ()
    follow forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< forall s. Int -> Dom s Int
    childM Int
    s)
      Int
    zv  <- forall s. Int -> Dom s Int
    sizeM Int
    v
      Int -> Dom s ()
    follow forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< case Int
    zv forall a. Ord a => a -> a -> Bool
    < Int
    2forall a. Num a => a -> a -> a
    *Int
    zw of
                  Bool
    False-> forall (m :: * -> *) a. Monad m => a -> m a
    return Int
    s
                  Bool
    True-> do
                    Int
    cv <- forall s. Int -> Dom s Int
    childM Int
    v
                    forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    childE Int
    v Int
    s
                    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
      ()
    _   <- forall s. Int -> Dom s ()
    go Int
    i
      Int
    n0  <- forall s. Dom s Int
    zeroM
      Int
    r   <- forall s. Dom s Int
    rootM
      forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store 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 <- forall s. Dom s Int
    nextM
              forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    dfnE   Int
    i Int
    n
              forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    sdnoE  Int
    i Int
    n
              forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    ndfsE  Int
    n Int
    i
              forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store forall s. Env s -> Arr s Int
    labelE Int
    i Int
    i
              Path
    ss <- forall s. Int -> Dom s Path
    succsM Int
    i
              forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ Path
    ss (\Int
    j-> do
                Int
    s <- forall s. Int -> Dom s Int
    sdnoM Int
    j
                case Int
    sforall a. Eq a => a -> a -> Bool
    ==Int
    0 of
                  Bool
    False-> forall (m :: * -> *) a. Monad m => a -> m a
    return()
                  Bool
    True-> do
                    forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> a -> S z s ()
    store 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 forall a. IntMap a -> Int -> a
    IM.! Int
    r0 -- renamed root
          n :: Int
    n         = forall a. IntMap a -> Int
    IM.size Graph
    g
          ns :: Path
    ns        = [Int
    0..Int
    n]
          m :: Int
    m         = Int
    nforall a. Num a => a -> a -> a
    +Int
    1

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

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

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

      -- Initialize all arrays
      forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [Int
    0..Int
    n] (Arr s Int
    domsforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
    .=Int
    0)
      forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [Int
    0..Int
    n] (Arr s Int
    sdnoforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
    .=Int
    0)
      forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [Int
    1..Int
    n] (Arr s Int
    sizeforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
    .=Int
    1)
      forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [Int
    0..Int
    n] (Arr s Int
    ancestorforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
    .=Int
    0)
      forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [Int
    0..Int
    n] (Arr s Int
    childforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
    .=Int
    0)

      (Arr s Int
    domsforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
    .=Int
    root) Int
    root
      (Arr s Int
    sizeforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
    .=Int
    0) Int
    0
      (Arr s Int
    labelforall s a. MArray (A s) a (ST s) => Arr s a -> a -> Int -> ST s ()
    .=Int
    0) Int
    0

      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   <- forall s a z. (s -> a) -> S z s a
    gets forall s. Env s -> Arr s Int
    domE
      Arr s Int
    rn    <- forall s a z. (s -> a) -> S z s a
    gets forall s. Env s -> Arr s Int
    rnE
      -- r     <- gets rootE
      (Int
    _,Int
    n) <- forall z a s. ST z a -> S z s a
    st (forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    a i e -> m (i, i)
    getBounds Arr s Int
    dom)
      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 <- forall z a s. ST z a -> S z s a
    st(Arr s Int
    rnforall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
    !:Int
    i)
        Int
    d <- forall z a s. ST z a -> S z s a
    st(Arr s Int
    domforall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
    !:Int
    i)
        Int
    k <- forall z a s. ST z a -> S z s a
    st(Arr s Int
    rnforall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
    !:Int
    d)
        forall (m :: * -> *) a. Monad m => a -> m a
    return (Int
    j,Int
    k))

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

    zeroM :: Dom s Node
    zeroM :: forall s. Dom s Int
    zeroM = forall s a z. (s -> a) -> S z s a
    gets forall s. Env s -> Int
    zeroE
    domM :: Node -> Dom s Node
    domM :: forall s. Int -> Dom s Int
    domM = forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> S z s a
    fetch forall s. Env s -> Arr s Int
    domE
    rootM :: Dom s Node
    rootM :: forall s. Dom s Int
    rootM = forall s a z. (s -> a) -> S z s a
    gets forall s. Env s -> Int
    rootE
    succsM :: Node -> Dom s [Node]
    succsM :: forall s. Int -> Dom s Path
    succsM Int
    i = forall s a z. (s -> a) -> S z s a
    gets (IntSet -> Path
    IS.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (forall a. Monoid a => IntMap a -> Int -> a
    ! Int
    i) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall s. Env s -> Graph
    succE)
    predsM :: Node -> Dom s [Node]
    predsM :: forall s. Int -> Dom s Path
    predsM Int
    i = forall s a z. (s -> a) -> S z s a
    gets (IntSet -> Path
    IS.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (forall a. Monoid a => IntMap a -> Int -> a
    ! Int
    i) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall s. Env s -> Graph
    predE)
    bucketM :: Node -> Dom s [Node]
    bucketM :: forall s. Int -> Dom s Path
    bucketM Int
    i = forall s a z. (s -> a) -> S z s a
    gets (IntSet -> Path
    IS.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (forall a. Monoid a => IntMap a -> Int -> a
    ! Int
    i) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall s. Env s -> Graph
    bucketE)
    sizeM :: Node -> Dom s Int
    sizeM :: forall s. Int -> Dom s Int
    sizeM = forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> S z s a
    fetch forall s. Env s -> Arr s Int
    sizeE
    sdnoM :: Node -> Dom s Int
    sdnoM :: forall s. Int -> Dom s Int
    sdnoM = forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> S z s a
    fetch 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 = forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> S z s a
    fetch forall s. Env s -> Arr s Int
    ndfsE
    childM :: Node -> Dom s Node
    childM :: forall s. Int -> Dom s Int
    childM = forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> S z s a
    fetch forall s. Env s -> Arr s Int
    childE
    ancestorM :: Node -> Dom s Node
    ancestorM :: forall s. Int -> Dom s Int
    ancestorM = forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> S z s a
    fetch forall s. Env s -> Arr s Int
    ancestorE
    parentM :: Node -> Dom s Node
    parentM :: forall s. Int -> Dom s Int
    parentM = forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> S z s a
    fetch forall s. Env s -> Arr s Int
    parentE
    labelM :: Node -> Dom s Node
    labelM :: forall s. Int -> Dom s Int
    labelM = forall z a s.
    MArray (A z) a (ST z) =>
    (s -> Arr z a) -> Int -> S z s a
    fetch forall s. Env s -> Arr s Int
    labelE
    nextM :: Dom s Int
    nextM :: forall s. Dom s Int
    nextM = do
      Int
    n <- forall s a z. (s -> a) -> S z s a
    gets forall s. Env s -> Int
    dfsE
      let n' :: Int
    n' = Int
    nforall a. Num a => a -> a -> a
    +Int
    1
      forall s z. (s -> s) -> S z s ()
    modify(\Env s
    e->Env s
    e{dfsE :: Int
    dfsE=Int
    n'})
      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 = 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 <- 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
      forall (m :: * -> *) a. Monad m => a -> m a
    return 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 = forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    (i, i) -> m (a i e)
    unsafeNewArray_ (Int
    0,Int
    nforall 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 = 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 = 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
    aforall 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 = forall b a. b -> (a -> b) -> Maybe a -> b
    maybe forall a. Monoid a => a
    mempty forall a. a -> a
    id (forall a. Int -> IntMap a -> Maybe a
    IM.lookup Int
    n IntMap a
    g)

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

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

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

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

    predG :: Graph -> Graph
    predG :: Graph -> Graph
    predG Graph
    g = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (forall a b. a -> b -> a
    const forall a. Monoid a => a
    mempty) Graph
    g
            go :: Graph -> Graph
    go = forall a b c. (a -> b -> c) -> b -> a -> c
    flip forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
    IM.foldrWithKey forall a. Monoid a => a
    mempty (\Int
    i IntSet
    a Graph
    m ->
                    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (\Graph
    m Int
    p -> forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
    IM.insertWith 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))

    pruneReach :: Rooted -> Rooted
    pruneReach :: Rooted -> Rooted
    pruneReach (Int
    r,Graph
    g) = (Int
    r,Graph
    g2)
      where is :: IntSet
    is = (Int -> IntSet) -> Int -> IntSet
    reachable
                  (forall b a. b -> (a -> b) -> Maybe a -> b
    maybe forall a. Monoid a => a
    mempty forall a. a -> a
    id
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b c. (a -> b -> c) -> b -> a -> c
    flip forall a. Int -> IntMap a -> Maybe a
    IM.lookup Graph
    g) forall a b. (a -> b) -> a -> b
    $ Int
    r
            g2 :: Graph
    g2 = forall a. [(Int, a)] -> IntMap a
    IM.fromList
                forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (forall (p :: * -> * -> *) b c a.
    Bifunctor p =>
    (b -> c) -> p a b -> p a c
    second ((Int -> Bool) -> IntSet -> IntSet
    IS.filter (Int -> IntSet -> Bool
    `IS.member`IntSet
    is)))
                forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a. (a -> Bool) -> [a] -> [a]
    filter ((Int -> IntSet -> Bool
    `IS.member`IntSet
    is) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (a, b) -> a
    fst)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a. IntMap a -> [(Int, a)]
    IM.toList 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) = forall {f :: * -> *} {b} {b}.
    Functor f =>
    b -> f (Tree b) -> f (b, b)
    p a
    i [Tree a]
    xs
            forall a. [a] -> [a] -> [a]
    ++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap forall a. Tree a -> [(a, a)]
    parents [Tree a]
    xs
      where p :: b -> f (Tree b) -> f (b, b)
    p b
    i = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (forall a b c. (a -> b -> c) -> b -> a -> c
    flip (,) b
    i forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a. Tree a -> a
    rootLabel)

    ancestors :: Tree a -> [(a, [a])]
    ancestors :: forall a. Tree a -> [(a, [a])]
    ancestors = 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
    iforall a. a -> [a] -> [a]
    :[b]
    acc
                in forall {f :: * -> *} {b} {b}.
    Functor f =>
    b -> f (Tree b) -> f (b, b)
    p [b]
    acc' [Tree b]
    xs forall a. [a] -> [a] -> [a]
    ++ 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (forall a b c. (a -> b -> c) -> b -> a -> c
    flip (,) b
    is forall b c a. (b -> c) -> (a -> b) -> a -> c
    . 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 = 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 = (forall a b. (a, b) -> a
    fst forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. [(a, b)] -> ([a], [b])
    unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap forall a. Tree a -> (a, [Tree a])
    tip) [Tree a]
    ts
                              in (a
    a, [a]
    as) forall a. 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 = forall a. a -> [Tree a] -> Tree a
    Node Int
    a (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Int -> Tree Int
    go ((IntSet -> Path
    IS.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> IntSet
    f) Int
    a))
                       f :: Int -> IntSet
    f = (Graph
    g forall a. Monoid a => IntMap a -> Int -> a
    !)
                in Int -> Tree Int
    go Int
    r

    reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
    reachable :: (Int -> IntSet) -> Int -> IntSet
    reachable Int -> IntSet
    f Int
    a = IntSet -> Int -> IntSet
    go (Int -> IntSet
    IS.singleton Int
    a) Int
    a
      where go :: IntSet -> Int -> IntSet
    go IntSet
    seen Int
    a = let s :: IntSet
    s = Int -> IntSet
    f Int
    a
                            as :: Path
    as = IntSet -> Path
    IS.toList (IntSet
    s IntSet -> IntSet -> IntSet
    `IS.difference` IntSet
    seen)
                        in 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
      = forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (\IntMap c
    m a
    a -> 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) 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 -> (Graph, NodeMap Node)
    renum :: Int -> Graph -> (Graph, NodeMap Int)
    renum Int
    from = (\(Int
    _,NodeMap Int
    m,Graph
    g)->(Graph
    g,NodeMap Int
    m))
      forall b c a. (b -> c) -> (a -> b) -> a -> c
    . 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) = 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,forall a. Monoid a => a
    mempty) IntSet
    ss
                  new2 :: Graph
    new2 = 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,forall a. Monoid a => a
    mempty,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 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
    nforall a. Num a => a -> a -> a
    +Int
    1,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 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 -> forall o. (a -> s -> ST z o) -> s -> ST z o
    g (b -> s -> ST z o
    k 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 = 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 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 -> forall o. (a -> s -> ST z o) -> s -> ST z o
    g (\a
    a -> 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 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
    (<*>) = 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 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 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 () 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) = forall o. (a -> s -> ST z o) -> s -> ST z o
    g ((forall (m :: * -> *) a. Monad m => a -> m a
    return forall b c a. (b -> c) -> (a -> b) -> a -> c
    .) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . 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 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 <- forall s a z. (s -> a) -> S z s a
    gets s -> Arr z a
    f
      forall z a s. ST z a -> S z s a
    st ((Arr z a
    aforall 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 <- forall s a z. (s -> a) -> S z s a
    gets s -> Arr z a
    f
      forall z a s. ST z a -> S z s a
    st (Arr z a
    aforall s a. MArray (A s) a (ST s) => A s Int a -> Int -> ST s a
    !:Int
    i)