-- Find Dominators of a graph.
--
-- Author: Bertram Felgenhauer <int-e@gmx.de>
--
-- Implementation based on
-- Keith D. Cooper, Timothy J. Harvey, Ken Kennedy,
-- "A Simple, Fast Dominance Algorithm",
-- (http://citeseer.ist.psu.edu/cooper01simple.html)

module Data.Graph.Inductive.Query.Dominators (
    dom,
    iDom
) where

import           Data.Array
import           Data.Graph.Inductive.Graph
import           Data.Graph.Inductive.Query.DFS
import           Data.IntMap                    (IntMap)
import qualified Data.IntMap                    as I
import           Data.Tree                      (Tree (..))
import qualified Data.Tree                      as T

{-# ANN iDom "HLint: ignore Use ***" #-}
-- | return immediate dominators for each node of a graph, given a root
iDom :: (Graph gr) => gr a b -> Node -> [(Node,Node)]
iDom :: gr a b -> Node -> [(Node, Node)]
iDom gr a b
g Node
root = let (IDom
result, IDom
toNode, FromNode
_) = gr a b -> Node -> (IDom, IDom, FromNode)
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> (IDom, IDom, FromNode)
idomWork gr a b
g Node
root
              in  ((Node, Node) -> (Node, Node)) -> [(Node, Node)] -> [(Node, Node)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Node
a, Node
b) -> (IDom
toNode IDom -> Node -> Node
forall i e. Ix i => Array i e -> i -> e
! Node
a, IDom
toNode IDom -> Node -> Node
forall i e. Ix i => Array i e -> i -> e
! Node
b)) (IDom -> [(Node, Node)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs IDom
result)

-- | return the set of dominators of the nodes of a graph, given a root
dom :: (Graph gr) => gr a b -> Node -> [(Node,[Node])]
dom :: gr a b -> Node -> [(Node, [Node])]
dom gr a b
g Node
root = let
    (IDom
iD, IDom
toNode, FromNode
fromNode) = gr a b -> Node -> (IDom, IDom, FromNode)
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> (IDom, IDom, FromNode)
idomWork gr a b
g Node
root
    dom' :: Array Node [Node]
dom' = IDom -> IDom -> Array Node [Node]
getDom IDom
toNode IDom
iD
    nodes' :: [Node]
nodes' = gr a b -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
nodes gr a b
g
    rest :: [Node]
rest = FromNode -> [Node]
forall a. IntMap a -> [Node]
I.keys ((Node -> Bool) -> FromNode -> FromNode
forall a. (a -> Bool) -> IntMap a -> IntMap a
I.filter (-Node
1 Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
==) FromNode
fromNode)
  in
    [(IDom
toNode IDom -> Node -> Node
forall i e. Ix i => Array i e -> i -> e
! Node
i, Array Node [Node]
dom' Array Node [Node] -> Node -> [Node]
forall i e. Ix i => Array i e -> i -> e
! Node
i) | Node
i <- (Node, Node) -> [Node]
forall a. Ix a => (a, a) -> [a]
range (Array Node [Node] -> (Node, Node)
forall i e. Array i e -> (i, i)
bounds Array Node [Node]
dom')] [(Node, [Node])] -> [(Node, [Node])] -> [(Node, [Node])]
forall a. [a] -> [a] -> [a]
++
    [(Node
n, [Node]
nodes') | Node
n <- [Node]
rest]

-- internal node type
type Node' = Int
-- array containing the immediate dominator of each node, or an approximation
-- thereof. the dominance set of a node can be found by taking the union of
-- {node} and the dominance set of its immediate dominator.
type IDom = Array Node' Node'
-- array containing the list of predecessors of each node
type Preds = Array Node' [Node']
-- arrays for translating internal nodes back to graph nodes and back
type ToNode = Array Node' Node
type FromNode = IntMap Node'

idomWork :: (Graph gr) => gr a b -> Node -> (IDom, ToNode, FromNode)
idomWork :: gr a b -> Node -> (IDom, IDom, FromNode)
idomWork gr a b
g Node
root = let
    -- use depth first tree from root do build the first approximation
    trees :: [Tree Node]
trees@(~[Tree Node
tree]) = [Node] -> gr a b -> [Tree Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Node] -> gr a b -> [Tree Node]
dff [Node
root] gr a b
g
    -- relabel the tree so that paths from the root have increasing nodes
    (Node
s, Tree Node
ntree) = Node -> Tree Node -> (Node, Tree Node)
forall a. Node -> Tree a -> (Node, Tree Node)
numberTree Node
0 Tree Node
tree
    -- the approximation iDom0 just maps each node to its parent
    iD0 :: IDom
iD0 = (Node, Node) -> [(Node, Node)] -> IDom
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Node
1, Node
sNode -> Node -> Node
forall a. Num a => a -> a -> a
-Node
1) ([(Node, Node)] -> [(Node, Node)]
forall a. [a] -> [a]
tail ([(Node, Node)] -> [(Node, Node)])
-> [(Node, Node)] -> [(Node, Node)]
forall a b. (a -> b) -> a -> b
$ Node -> Tree Node -> [(Node, Node)]
forall a. a -> Tree a -> [(a, a)]
treeEdges (-Node
1) Tree Node
ntree)
    -- fromNode translates graph nodes to relabeled (internal) nodes
    fromNode :: FromNode
fromNode = (Node -> Node -> Node) -> FromNode -> FromNode -> FromNode
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
I.unionWith Node -> Node -> Node
forall a b. a -> b -> a
const ([(Node, Node)] -> FromNode
forall a. [(Node, a)] -> IntMap a
I.fromList ([Node] -> [Node] -> [(Node, Node)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Tree Node -> [Node]
forall a. Tree a -> [a]
T.flatten Tree Node
tree) (Tree Node -> [Node]
forall a. Tree a -> [a]
T.flatten Tree Node
ntree))) ([(Node, Node)] -> FromNode
forall a. [(Node, a)] -> IntMap a
I.fromList ([Node] -> [Node] -> [(Node, Node)]
forall a b. [a] -> [b] -> [(a, b)]
zip (gr a b -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
nodes gr a b
g) (Node -> [Node]
forall a. a -> [a]
repeat (-Node
1))))
    -- toNode translates internal nodes to graph nodes
    toNode :: IDom
toNode = (Node, Node) -> [(Node, Node)] -> IDom
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Node
0, Node
sNode -> Node -> Node
forall a. Num a => a -> a -> a
-Node
1) ([Node] -> [Node] -> [(Node, Node)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Tree Node -> [Node]
forall a. Tree a -> [a]
T.flatten Tree Node
ntree) (Tree Node -> [Node]
forall a. Tree a -> [a]
T.flatten Tree Node
tree))
    preds :: Array Node [Node]
preds = (Node, Node) -> [(Node, [Node])] -> Array Node [Node]
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Node
1, Node
sNode -> Node -> Node
forall a. Num a => a -> a -> a
-Node
1) [(Node
i, (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter (Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
/= -Node
1) ((Node -> Node) -> [Node] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (FromNode
fromNode FromNode -> Node -> Node
forall a. IntMap a -> Node -> a
I.!)
                            (gr a b -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
pre gr a b
g (IDom
toNode IDom -> Node -> Node
forall i e. Ix i => Array i e -> i -> e
! Node
i)))) | Node
i <- [Node
1..Node
sNode -> Node -> Node
forall a. Num a => a -> a -> a
-Node
1]]
    -- iteratively improve the approximation to find iDom.
    iD :: IDom
iD = (IDom -> IDom) -> IDom -> IDom
forall a. Eq a => (a -> a) -> a -> a
fixEq (Array Node [Node] -> IDom -> IDom
refineIDom Array Node [Node]
preds) IDom
iD0
  in
    if [Tree Node] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tree Node]
trees then [Char] -> (IDom, IDom, FromNode)
forall a. HasCallStack => [Char] -> a
error [Char]
"Dominators.idomWork: root not in graph"
                  else (IDom
iD, IDom
toNode, FromNode
fromNode)

-- for each node in iDom, find the intersection of all its predecessor's
-- dominating sets, and update iDom accordingly.
refineIDom :: Preds -> IDom -> IDom
refineIDom :: Array Node [Node] -> IDom -> IDom
refineIDom Array Node [Node]
preds IDom
iD = ([Node] -> Node) -> Array Node [Node] -> IDom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Node -> Node -> Node) -> [Node] -> Node
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (IDom -> Node -> Node -> Node
intersect IDom
iD)) Array Node [Node]
preds

-- find the intersection of the two given dominance sets.
intersect :: IDom -> Node' -> Node' -> Node'
intersect :: IDom -> Node -> Node -> Node
intersect IDom
iD Node
a Node
b = case Node
a Node -> Node -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Node
b of
    Ordering
LT -> IDom -> Node -> Node -> Node
intersect IDom
iD Node
a (IDom
iD IDom -> Node -> Node
forall i e. Ix i => Array i e -> i -> e
! Node
b)
    Ordering
EQ -> Node
a
    Ordering
GT -> IDom -> Node -> Node -> Node
intersect IDom
iD (IDom
iD IDom -> Node -> Node
forall i e. Ix i => Array i e -> i -> e
! Node
a) Node
b

-- convert an IDom to dominance sets. we translate to graph nodes here
-- because mapping later would be more expensive and lose sharing.
getDom :: ToNode -> IDom -> Array Node' [Node]
getDom :: IDom -> IDom -> Array Node [Node]
getDom IDom
toNode IDom
iD = let
    res :: Array Node [Node]
res = (Node, Node) -> [(Node, [Node])] -> Array Node [Node]
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Node
0, (Node, Node) -> Node
forall a b. (a, b) -> b
snd (IDom -> (Node, Node)
forall i e. Array i e -> (i, i)
bounds IDom
iD)) ((Node
0, [IDom
toNode IDom -> Node -> Node
forall i e. Ix i => Array i e -> i -> e
! Node
0]) (Node, [Node]) -> [(Node, [Node])] -> [(Node, [Node])]
forall a. a -> [a] -> [a]
:
          [(Node
i, IDom
toNode IDom -> Node -> Node
forall i e. Ix i => Array i e -> i -> e
! Node
i Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: Array Node [Node]
res Array Node [Node] -> Node -> [Node]
forall i e. Ix i => Array i e -> i -> e
! (IDom
iD IDom -> Node -> Node
forall i e. Ix i => Array i e -> i -> e
! Node
i)) | Node
i <- (Node, Node) -> [Node]
forall a. Ix a => (a, a) -> [a]
range (IDom -> (Node, Node)
forall i e. Array i e -> (i, i)
bounds IDom
iD)])
  in
    Array Node [Node]
res

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

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

-- return the edges of the tree, with an added dummy root node.
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

-- find a fixed point of f, iteratively
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

{-
:m +Data.Graph.Inductive
let g0 = mkGraph [(i,()) | i <- [0..4]] [(a,b,()) | (a,b) <- [(0,1),(1,2),(0,3),(3,2),(4,0)]] :: Gr () ()
let g1 = mkGraph [(i,()) | i <- [0..4]] [(a,b,()) | (a,b) <- [(0,1),(1,2),(2,3),(1,3),(3,4)]] :: Gr () ()
let g2,g3,g4 :: Int -> Gr () (); g2 n = mkGraph [(i,()) | i <- [0..n-1]] ([(a,a+1,()) | a <- [0..n-2]] ++ [(a,a+2,()) | a <- [0..n-3]]); g3 n =mkGraph [(i,()) | i <- [0..n-1]] ([(a,a+2,()) | a <- [0..n-3]] ++ [(a,a+1,()) | a <- [0..n-2]]); g4 n =mkGraph [(i,()) | i <- [0..n-1]] ([(a+2,a,()) | a <- [0..n-3]] ++ [(a+1,a,()) | a <- [0..n-2]])
:m -Data.Graph.Inductive
-}