-- | Compute the dominators in a graph from a root node.
--
-- The set of dominators for a 'Vertex' in a graph is always with regard
-- to a @root@ 'Vertex', given as input to the algorithm.  'Vertex' @d@
-- dominates 'Vertex' @v@ if every path from the @root@ to @v@ must go
-- through @d@.  @d@ strictly dominates @v@ if @d@ dominates @v@ and is not
-- @v@.  The immediate dominator of @v@ is the unique 'Vertex' that strictly
-- dominates @v@ and does not strictly dominate any other 'Vertex' that
-- dominates @v@.
--
-- This implementation is ported from FGL (<http://hackage.haskell.org/package/fgl>)
-- and is substantially similar.  The major change is that it uses the vector
-- library instead of array.
--
-- The algorithm is based on \"A Simple, Fast Dominance Algorithm\" by
-- Cooper, Harvey, and Kennedy
--
-- <http://www.cs.rice.edu/~keith/EMBED/dom.pdf>
--
-- This is not Tarjan's algorithm; supposedly this is faster in practice
-- for most graphs.
module Data.Graph.Haggle.Algorithms.Dominators (
  immediateDominators,
  dominators
  ) where

import Data.Map ( Map )
import qualified Data.Map as M
import Data.Maybe ( fromMaybe )
import Data.Set ( Set )
import qualified Data.Set as S
import Data.Tree ( Tree(..) )
import qualified Data.Tree as T
import Data.Vector ( Vector, (!) )
import qualified Data.Vector as V

import Data.Graph.Haggle
import Data.Graph.Haggle.Algorithms.DFS

type ToNode = Vector Vertex
type FromNode = Map Vertex Int
type IDom = Vector Int
type Preds = Vector [Int]

-- | Compute the immediate dominators in the graph from the @root@ 'Vertex'.
-- Each 'Vertex' reachable from the @root@ will be paired with its immediate
-- dominator.  Note that there is no entry in the result pairing for the
-- root 'Vertex' because it has no immediate dominator.
--
-- If the root vertex is not in the graph, an empty list is returned.
immediateDominators :: (Graph g) => g -> Vertex -> [(Vertex, Vertex)]
immediateDominators :: g -> Vertex -> [(Vertex, Vertex)]
immediateDominators g
g Vertex
root = [(Vertex, Vertex)]
-> Maybe [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Vertex, Vertex)] -> [(Vertex, Vertex)])
-> Maybe [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> a -> b
$ do
  (IDom
res, ToNode
toNode, FromNode
_) <- g -> Vertex -> Maybe (IDom, ToNode, FromNode)
forall g. Graph g => g -> Vertex -> Maybe (IDom, ToNode, FromNode)
domWork g
g Vertex
root
  [(Vertex, Vertex)] -> Maybe [(Vertex, Vertex)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Vertex, Vertex)] -> Maybe [(Vertex, Vertex)])
-> [(Vertex, Vertex)] -> Maybe [(Vertex, Vertex)]
forall a b. (a -> b) -> a -> b
$ [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. [a] -> [a]
tail ([(Vertex, Vertex)] -> [(Vertex, Vertex)])
-> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> a -> b
$ Vector (Vertex, Vertex) -> [(Vertex, Vertex)]
forall a. Vector a -> [a]
V.toList (Vector (Vertex, Vertex) -> [(Vertex, Vertex)])
-> Vector (Vertex, Vertex) -> [(Vertex, Vertex)]
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> (Vertex, Vertex)) -> IDom -> Vector (Vertex, Vertex)
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap (\Int
i Int
n -> (ToNode
toNodeToNode -> Int -> Vertex
forall a. Vector a -> Int -> a
!Int
i, ToNode
toNodeToNode -> Int -> Vertex
forall a. Vector a -> Int -> a
!Int
n)) IDom
res

-- | Compute all of the dominators for each 'Vertex' reachable from the @root@.
-- Each reachable 'Vertex' is paired with the list of nodes that dominate it,
-- including the 'Vertex' itself.  The @root@ is only dominated by itself.
dominators :: (Graph g) => g -> Vertex -> [(Vertex, [Vertex])]
dominators :: g -> Vertex -> [(Vertex, [Vertex])]
dominators g
g Vertex
root = [(Vertex, [Vertex])]
-> Maybe [(Vertex, [Vertex])] -> [(Vertex, [Vertex])]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Vertex, [Vertex])] -> [(Vertex, [Vertex])])
-> Maybe [(Vertex, [Vertex])] -> [(Vertex, [Vertex])]
forall a b. (a -> b) -> a -> b
$ do
  (IDom
res, ToNode
toNode, FromNode
fromNode) <- g -> Vertex -> Maybe (IDom, ToNode, FromNode)
forall g. Graph g => g -> Vertex -> Maybe (IDom, ToNode, FromNode)
domWork g
g Vertex
root
  let dom' :: Vector [Vertex]
dom' = ToNode -> IDom -> Vector [Vertex]
getDom ToNode
toNode IDom
res
      rest :: [Vertex]
rest = FromNode -> [Vertex]
forall k a. Map k a -> [k]
M.keys ((Int -> Bool) -> FromNode -> FromNode
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (-Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) FromNode
fromNode)
      verts :: [Vertex]
verts = g -> [Vertex]
forall g. Graph g => g -> [Vertex]
vertices g
g
  [(Vertex, [Vertex])] -> Maybe [(Vertex, [Vertex])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Vertex, [Vertex])] -> Maybe [(Vertex, [Vertex])])
-> [(Vertex, [Vertex])] -> Maybe [(Vertex, [Vertex])]
forall a b. (a -> b) -> a -> b
$ [(ToNode
toNode ToNode -> Int -> Vertex
forall a. Vector a -> Int -> a
! Int
i, Vector [Vertex]
dom' Vector [Vertex] -> Int -> [Vertex]
forall a. Vector a -> Int -> a
! Int
i) | Int
i <- [Int
0..Vector [Vertex] -> Int
forall a. Vector a -> Int
V.length Vector [Vertex]
dom' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]] [(Vertex, [Vertex])]
-> [(Vertex, [Vertex])] -> [(Vertex, [Vertex])]
forall a. [a] -> [a] -> [a]
++
           [(Vertex
n, [Vertex]
verts) | Vertex
n <- [Vertex]
rest]

domWork :: (Graph g) => g -> Vertex -> Maybe (IDom, ToNode, FromNode)
domWork :: g -> Vertex -> Maybe (IDom, ToNode, FromNode)
domWork g
g Vertex
root
  | [Tree Vertex] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tree Vertex]
trees = Maybe (IDom, ToNode, FromNode)
forall a. Maybe a
Nothing
  | Bool
otherwise = (IDom, ToNode, FromNode) -> Maybe (IDom, ToNode, FromNode)
forall (m :: * -> *) a. Monad m => a -> m a
return (IDom
idom, ToNode
toNode, FromNode
fromNode)
  where
    -- Build up a depth-first tree from the root as a first approximation
    trees :: [Tree Vertex]
trees@(~[Tree Vertex
tree]) = g -> [Vertex] -> [Tree Vertex]
forall g. Graph g => g -> [Vertex] -> [Tree Vertex]
dff g
g [Vertex
root]
    (Int
s, Tree Int
ntree) = Int -> Tree Vertex -> (Int, Tree Int)
forall a. Int -> Tree a -> (Int, Tree Int)
numberTree Int
0 Tree Vertex
tree
    -- Start with an approximation (idom0) where the idom of each node is
    -- its parent in the depth-first tree.  Note that index 0 is the root,
    -- which we will basically be ignoring (since it has no dominator).
    dom0Map :: Map Int Int
dom0Map = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (Int -> Tree Int -> [(Int, Int)]
forall a. a -> Tree a -> [(a, a)]
treeEdges (-Int
1) Tree Int
ntree)
    idom0 :: IDom
idom0 = Int -> (Int -> Int) -> IDom
forall a. Int -> (Int -> a) -> Vector a
V.generate (Map Int Int -> Int
forall k a. Map k a -> Int
M.size Map Int Int
dom0Map) (Map Int Int
dom0Map Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
M.!)
    -- Build a mapping from graph vertices to internal indices.  @treeNodes@
    -- are nodes that are in the depth-first tree from the root.  @otherNodes@
    -- are the rest of the nodes in the graph, mapped to -1 (since they aren't
    -- going to be in the result)
    treeNodes :: FromNode
treeNodes = [(Vertex, Int)] -> FromNode
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Vertex, Int)] -> FromNode) -> [(Vertex, Int)] -> FromNode
forall a b. (a -> b) -> a -> b
$ [Vertex] -> [Int] -> [(Vertex, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Tree Vertex -> [Vertex]
forall a. Tree a -> [a]
T.flatten Tree Vertex
tree) (Tree Int -> [Int]
forall a. Tree a -> [a]
T.flatten Tree Int
ntree)
    otherNodes :: FromNode
otherNodes = [(Vertex, Int)] -> FromNode
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Vertex, Int)] -> FromNode) -> [(Vertex, Int)] -> FromNode
forall a b. (a -> b) -> a -> b
$ [Vertex] -> [Int] -> [(Vertex, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (g -> [Vertex]
forall g. Graph g => g -> [Vertex]
vertices g
g) (Int -> [Int]
forall a. a -> [a]
repeat (-Int
1))
    fromNode :: FromNode
fromNode = (Int -> Int -> Int) -> FromNode -> FromNode -> FromNode
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Int -> Int -> Int
forall a b. a -> b -> a
const FromNode
treeNodes FromNode
otherNodes
    -- Translate from internal nodes back to graph nodes (only need the nodes
    -- in the depth-first tree)
    toNodeMap :: Map Int Vertex
toNodeMap = [(Int, Vertex)] -> Map Int Vertex
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Int, Vertex)] -> Map Int Vertex)
-> [(Int, Vertex)] -> Map Int Vertex
forall a b. (a -> b) -> a -> b
$ [Int] -> [Vertex] -> [(Int, Vertex)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Tree Int -> [Int]
forall a. Tree a -> [a]
T.flatten Tree Int
ntree) (Tree Vertex -> [Vertex]
forall a. Tree a -> [a]
T.flatten Tree Vertex
tree)
    toNode :: ToNode
toNode = Int -> (Int -> Vertex) -> ToNode
forall a. Int -> (Int -> a) -> Vector a
V.generate (Map Int Vertex -> Int
forall k a. Map k a -> Int
M.size Map Int Vertex
toNodeMap) (Map Int Vertex
toNodeMap Map Int Vertex -> Int -> Vertex
forall k a. Ord k => Map k a -> k -> a
M.!)

    -- Use a pre-pass over the graph to collect predecessors so that we don't
    -- require a Bidirectional graph.  We need a linear pass over the graph
    -- here anyway, so we don't lose anything.
    predMap :: Map Vertex [Vertex]
predMap = (Set Vertex -> [Vertex])
-> Map Vertex (Set Vertex) -> Map Vertex [Vertex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set Vertex -> [Vertex]
forall a. Set a -> [a]
S.toList (Map Vertex (Set Vertex) -> Map Vertex [Vertex])
-> Map Vertex (Set Vertex) -> Map Vertex [Vertex]
forall a b. (a -> b) -> a -> b
$ (Vertex -> Map Vertex (Set Vertex) -> Map Vertex (Set Vertex))
-> Map Vertex (Set Vertex) -> [Vertex] -> Map Vertex (Set Vertex)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (g -> Vertex -> Map Vertex (Set Vertex) -> Map Vertex (Set Vertex)
forall g.
Graph g =>
g -> Vertex -> Map Vertex (Set Vertex) -> Map Vertex (Set Vertex)
toPredecessor g
g) Map Vertex (Set Vertex)
forall k a. Map k a
M.empty (g -> [Vertex]
forall g. Graph g => g -> [Vertex]
vertices g
g)
    preds :: Vector [Int]
preds = [[Int]] -> Vector [Int]
forall a. [a] -> Vector a
V.fromList ([[Int]] -> Vector [Int]) -> [[Int]] -> Vector [Int]
forall a b. (a -> b) -> a -> b
$ [Int
0] [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [(Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= -Int
1) ((Vertex -> Int) -> [Vertex] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (FromNode
fromNode FromNode -> Vertex -> Int
forall k a. Ord k => Map k a -> k -> a
M.!) (Map Vertex [Vertex]
predMap Map Vertex [Vertex] -> Vertex -> [Vertex]
forall k a. Ord k => Map k a -> k -> a
M.! (ToNode
toNode ToNode -> Int -> Vertex
forall a. Vector a -> Int -> a
! Int
i)))
                               | Int
i <- [Int
1..Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
    idom :: IDom
idom = (IDom -> IDom) -> IDom -> IDom
forall a. Eq a => (a -> a) -> a -> a
fixEq (Vector [Int] -> IDom -> IDom
refineIDom Vector [Int]
preds) IDom
idom0

toPredecessor :: (Graph g)
              => g
              -> Vertex
              -> Map Vertex (Set Vertex)
              -> Map Vertex (Set Vertex)
toPredecessor :: g -> Vertex -> Map Vertex (Set Vertex) -> Map Vertex (Set Vertex)
toPredecessor g
g Vertex
pre Map Vertex (Set Vertex)
m = (Vertex -> Map Vertex (Set Vertex) -> Map Vertex (Set Vertex))
-> Map Vertex (Set Vertex) -> [Vertex] -> Map Vertex (Set Vertex)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Vertex -> Map Vertex (Set Vertex) -> Map Vertex (Set Vertex)
forall k. Ord k => k -> Map k (Set Vertex) -> Map k (Set Vertex)
addPred Map Vertex (Set Vertex)
m (g -> Vertex -> [Vertex]
forall g. Graph g => g -> Vertex -> [Vertex]
successors g
g Vertex
pre)
  where
    addPred :: k -> Map k (Set Vertex) -> Map k (Set Vertex)
addPred k
suc = (Set Vertex -> Set Vertex -> Set Vertex)
-> k -> Set Vertex -> Map k (Set Vertex) -> Map k (Set Vertex)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Set Vertex -> Set Vertex -> Set Vertex
forall a. Ord a => Set a -> Set a -> Set a
S.union k
suc (Vertex -> Set Vertex
forall a. a -> Set a
S.singleton Vertex
pre)

refineIDom :: Preds -> IDom -> IDom
refineIDom :: Vector [Int] -> IDom -> IDom
refineIDom Vector [Int]
preds IDom
idom = ([Int] -> Int) -> Vector [Int] -> IDom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Int -> Int) -> [Int] -> Int
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (IDom -> Int -> Int -> Int
intersect IDom
idom)) Vector [Int]
preds

intersect :: IDom -> Int -> Int -> Int
intersect :: IDom -> Int -> Int -> Int
intersect IDom
idom Int
a Int
b =
  case Int
a Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int
b of
    Ordering
LT -> IDom -> Int -> Int -> Int
intersect IDom
idom Int
a (IDom
idom IDom -> Int -> Int
forall a. Vector a -> Int -> a
! Int
b)
    Ordering
EQ -> Int
a
    Ordering
GT -> IDom -> Int -> Int -> Int
intersect IDom
idom (IDom
idom IDom -> Int -> Int
forall a. Vector a -> Int -> a
! Int
a) Int
b

-- Helpers

getDom :: ToNode -> IDom -> Vector [Vertex]
getDom :: ToNode -> IDom -> Vector [Vertex]
getDom ToNode
toNode IDom
idom = Vector [Vertex]
res
  where
    -- The root dominates itself (the only dominator for the root)
    root :: [Vertex]
root = [ToNode
toNode ToNode -> Int -> Vertex
forall a. Vector a -> Int -> a
! Int
0]
    res :: Vector [Vertex]
res = [[Vertex]] -> Vector [Vertex]
forall a. [a] -> Vector a
V.fromList ([[Vertex]] -> Vector [Vertex]) -> [[Vertex]] -> Vector [Vertex]
forall a b. (a -> b) -> a -> b
$ [Vertex]
root [Vertex] -> [[Vertex]] -> [[Vertex]]
forall a. a -> [a] -> [a]
: [ToNode
toNode ToNode -> Int -> Vertex
forall a. Vector a -> Int -> a
! Int
i Vertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
: Vector [Vertex]
res Vector [Vertex] -> Int -> [Vertex]
forall a. Vector a -> Int -> a
! (IDom
idom IDom -> Int -> Int
forall a. Vector a -> Int -> a
! Int
i) | Int
i <- [Int
1..IDom -> Int
forall a. Vector a -> Int
V.length IDom
idom Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

treeEdges :: a -> Tree a -> [(a,a)]
treeEdges :: a -> Tree a -> [(a, a)]
treeEdges a
a (Node a
b Forest a
ts) = (a
b,a
a) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: (Tree a -> [(a, a)]) -> Forest a -> [(a, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (a -> Tree a -> [(a, a)]
forall a. a -> Tree a -> [(a, a)]
treeEdges a
b) Forest a
ts

-- relabel tree, labeling vertices with consecutive numbers in depth first order
numberTree :: Int -> Tree a -> (Int, Tree Int)
numberTree :: Int -> Tree a -> (Int, Tree Int)
numberTree Int
n (Node a
_ Forest a
ts) = let (Int
n', [Tree Int]
ts') = Int -> Forest a -> (Int, [Tree Int])
forall a. Int -> [Tree a] -> (Int, [Tree Int])
numberForest (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Forest a
ts
                           in  (Int
n', Int -> [Tree Int] -> Tree Int
forall a. a -> Forest a -> Tree a
Node Int
n [Tree Int]
ts')

-- same as numberTree, for forests.
numberForest :: Int -> [Tree a] -> (Int, [Tree Int])
numberForest :: Int -> [Tree a] -> (Int, [Tree Int])
numberForest Int
n []     = (Int
n, [])
numberForest Int
n (Tree a
t:[Tree a]
ts) = let (Int
n', Tree Int
t')   = Int -> Tree a -> (Int, Tree Int)
forall a. Int -> Tree a -> (Int, Tree Int)
numberTree Int
n Tree a
t
                            (Int
n'', [Tree Int]
ts') = Int -> [Tree a] -> (Int, [Tree Int])
forall a. Int -> [Tree a] -> (Int, [Tree Int])
numberForest Int
n' [Tree a]
ts
                        in  (Int
n'', Tree Int
t'Tree Int -> [Tree Int] -> [Tree Int]
forall a. a -> [a] -> [a]
:[Tree Int]
ts')

fixEq :: Eq a => (a -> a) -> a -> a
fixEq :: (a -> a) -> a -> a
fixEq a -> a
f a
v
  | a
v' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v   = a
v
  | Bool
otherwise = (a -> a) -> a -> a
forall a. Eq a => (a -> a) -> a -> a
fixEq a -> a
f a
v'
  where
    v' :: a
v' = a -> a
f a
v