-- 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.Maybe (mapMaybe)
import           Data.Tree                      (Tree (..))
import qualified Data.Tree                      as T

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

-- | return the set of dominators of the reachable nodes of a graph, given a root
dom :: (Graph gr) => gr a b -> Node -> [(Node,[Node])]
dom :: forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node' -> [(Node', [Node'])]
dom gr a b
g Node'
root = let
    (IDom
iD, IDom
toNode, FromNode
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' = forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node']
nodes gr a b
g
    rest :: [Node']
rest = forall a. IntMap a -> [Node']
I.keys (forall a. (a -> Bool) -> IntMap a -> IntMap a
I.filter (-Node'
1 forall a. Eq a => a -> a -> Bool
==) FromNode
fromNode)
  in
    [(IDom
toNode forall i e. Ix i => Array i e -> i -> e
! Node'
i, Array Node' [Node']
dom' forall i e. Ix i => Array i e -> i -> e
! Node'
i) | Node'
i <- forall a. Ix a => (a, a) -> [a]
range (forall i e. Array i e -> (i, i)
bounds Array Node' [Node']
dom')] 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 :: forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node' -> (IDom, IDom, FromNode)
idomWork gr a b
g Node'
root = let
    nds :: [Node']
nds = forall (gr :: * -> * -> *) a b.
Graph gr =>
Node' -> gr a b -> [Node']
reachable Node'
root gr a b
g
    -- use depth first tree from root do build the first approximation
    trees :: [Tree Node']
trees@(~[Tree Node'
tree]) = 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) = 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 = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Node'
1, Node'
sforall a. Num a => a -> a -> a
-Node'
1) (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. a -> Tree a -> [(a, a)]
treeEdges (-Node'
1) Tree Node'
ntree)
    -- fromNode translates graph nodes to relabeled (internal) nodes
    fromNode :: FromNode
fromNode = forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
I.unionWith forall a b. a -> b -> a
const (forall a. [(Node', a)] -> IntMap a
I.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Tree a -> [a]
T.flatten Tree Node'
tree) (forall a. Tree a -> [a]
T.flatten Tree Node'
ntree))) (forall a. [(Node', a)] -> IntMap a
I.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Node']
nds (forall a. a -> [a]
repeat (-Node'
1))))
    -- toNode translates internal nodes to graph nodes
    toNode :: IDom
toNode = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Node'
0, Node'
sforall a. Num a => a -> a -> a
-Node'
1) (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Tree a -> [a]
T.flatten Tree Node'
ntree) (forall a. Tree a -> [a]
T.flatten Tree Node'
tree))
    preds :: Array Node' [Node']
preds = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Node'
1, Node'
sforall a. Num a => a -> a -> a
-Node'
1) [(Node'
i, forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= -Node'
1) (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. Node' -> IntMap a -> Maybe a
`I.lookup` FromNode
fromNode)
                            (forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node' -> [Node']
pre gr a b
g (IDom
toNode forall i e. Ix i => Array i e -> i -> e
! Node'
i)))) | Node'
i <- [Node'
1..Node'
sforall a. Num a => a -> a -> a
-Node'
1]]
    -- iteratively improve the approximation to find iDom.
    iD :: IDom
iD = forall a. Eq a => (a -> a) -> a -> a
fixEq (Array Node' [Node'] -> IDom -> IDom
refineIDom Array Node' [Node']
preds) IDom
iD0
  in
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tree Node']
trees then 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 forall a. Ord a => a -> a -> Ordering
`compare` Node'
b of
    Ordering
LT -> IDom -> Node' -> Node' -> Node'
intersect IDom
iD Node'
a (IDom
iD 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 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 = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Node'
0, forall a b. (a, b) -> b
snd (forall i e. Array i e -> (i, i)
bounds IDom
iD)) ((Node'
0, [IDom
toNode forall i e. Ix i => Array i e -> i -> e
! Node'
0]) forall a. a -> [a] -> [a]
:
          [(Node'
i, IDom
toNode forall i e. Ix i => Array i e -> i -> e
! Node'
i forall a. a -> [a] -> [a]
: Array Node' [Node']
res forall i e. Ix i => Array i e -> i -> e
! (IDom
iD forall i e. Ix i => Array i e -> i -> e
! Node'
i)) | Node'
i <- forall a. Ix a => (a, a) -> [a]
range (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 :: forall a. Node' -> Tree a -> (Node', Tree Node')
numberTree Node'
n (Node a
_ [Tree a]
ts) = let (Node'
n', [Tree Node']
ts') = forall a. Node' -> [Tree a] -> (Node', [Tree Node'])
numberForest (Node'
nforall a. Num a => a -> a -> a
+Node'
1) [Tree a]
ts
                           in  (Node'
n', forall a. a -> [Tree a] -> Tree a
Node Node'
n [Tree Node']
ts')

-- same as numberTree, for forests.
numberForest :: Node' -> [Tree a] -> (Node', [Tree Node'])
numberForest :: forall a. 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')   = forall a. Node' -> Tree a -> (Node', Tree Node')
numberTree Node'
n Tree a
t
                            (Node'
n'', [Tree Node']
ts') = forall a. Node' -> [Tree a] -> (Node', [Tree Node'])
numberForest Node'
n' [Tree a]
ts
                        in  (Node'
n'', Tree Node'
t'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 :: forall a. a -> Tree a -> [(a, a)]
treeEdges a
a (Node a
b [Tree a]
ts) = (a
b,a
a) forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. a -> Tree a -> [(a, a)]
treeEdges a
b) [Tree a]
ts

-- find a fixed point of f, iteratively
fixEq :: (Eq a) => (a -> a) -> a -> a
fixEq :: forall a. Eq a => (a -> a) -> a -> a
fixEq a -> a
f a
v | a
v' forall a. Eq a => a -> a -> Bool
== a
v   = a
v
          | Bool
otherwise = 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
-}