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]
immediateDominators :: (Graph g) => g -> Vertex -> [(Vertex, Vertex)]
immediateDominators :: forall g. Graph g => g -> Vertex -> [(Vertex, Vertex)]
immediateDominators g
g Vertex
root = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
(IDom
res, ToNode
toNode, FromNode
_) <- forall g. Graph g => g -> Vertex -> Maybe (IDom, ToNode, FromNode)
domWork g
g Vertex
root
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
V.toList forall a b. (a -> b) -> a -> b
$ forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap (\Int
i Int
n -> (ToNode
toNodeforall a. Vector a -> Int -> a
!Int
i, ToNode
toNodeforall a. Vector a -> Int -> a
!Int
n)) IDom
res
dominators :: (Graph g) => g -> Vertex -> [(Vertex, [Vertex])]
dominators :: forall g. Graph g => g -> Vertex -> [(Vertex, [Vertex])]
dominators g
g Vertex
root = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
(IDom
res, ToNode
toNode, FromNode
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 = forall k a. Map k a -> [k]
M.keys (forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (-Int
1 forall a. Eq a => a -> a -> Bool
==) FromNode
fromNode)
verts :: [Vertex]
verts = forall g. Graph g => Vertex -> g -> [Vertex]
reachable Vertex
root g
g
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(ToNode
toNode forall a. Vector a -> Int -> a
! Int
i, Vector [Vertex]
dom' forall a. Vector a -> Int -> a
! Int
i) | Int
i <- [Int
0..forall a. Vector a -> Int
V.length Vector [Vertex]
dom' forall a. Num a => a -> a -> a
- Int
1]] forall a. [a] -> [a] -> [a]
++
[(Vertex
n, [Vertex]
verts) | Vertex
n <- [Vertex]
rest]
domWork :: (Graph g) => g -> Vertex -> Maybe (IDom, ToNode, FromNode)
domWork :: forall g. Graph g => g -> Vertex -> Maybe (IDom, ToNode, FromNode)
domWork g
g Vertex
root
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tree Vertex]
trees = forall a. Maybe a
Nothing
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (IDom
idom, ToNode
toNode, FromNode
fromNode)
where
vlist :: [Vertex]
vlist = forall g. Graph g => Vertex -> g -> [Vertex]
reachable Vertex
root g
g
trees :: [Tree Vertex]
trees@(~[Tree Vertex
tree]) = forall g. Graph g => g -> [Vertex] -> [Tree Vertex]
dff g
g [Vertex
root]
(Int
s, Tree Int
ntree) = forall a. Int -> Tree a -> (Int, Tree Int)
numberTree Int
0 Tree Vertex
tree
dom0Map :: Map Int Int
dom0Map = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a. a -> Tree a -> [(a, a)]
treeEdges (-Int
1) Tree Int
ntree)
idom0 :: IDom
idom0 = forall a. Int -> (Int -> a) -> Vector a
V.generate (forall k a. Map k a -> Int
M.size Map Int Int
dom0Map) (Map Int Int
dom0Map forall k a. Ord k => Map k a -> k -> a
M.!)
treeNodes :: FromNode
treeNodes = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Tree a -> [a]
T.flatten Tree Vertex
tree) (forall a. Tree a -> [a]
T.flatten Tree Int
ntree)
otherNodes :: FromNode
otherNodes = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Vertex]
vlist (forall a. a -> [a]
repeat (-Int
1))
fromNode :: FromNode
fromNode = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a b. a -> b -> a
const FromNode
treeNodes FromNode
otherNodes
toNodeMap :: Map Int Vertex
toNodeMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Tree a -> [a]
T.flatten Tree Int
ntree) (forall a. Tree a -> [a]
T.flatten Tree Vertex
tree)
toNode :: ToNode
toNode = forall a. Int -> (Int -> a) -> Vector a
V.generate (forall k a. Map k a -> Int
M.size Map Int Vertex
toNodeMap) (Map Int Vertex
toNodeMap forall k a. Ord k => Map k a -> k -> a
M.!)
predMap :: Map Vertex [Vertex]
predMap = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall g.
Graph g =>
g -> Vertex -> Map Vertex (Set Vertex) -> Map Vertex (Set Vertex)
toPredecessor g
g) forall k a. Map k a
M.empty [Vertex]
vlist
preds :: Vector [Int]
preds = forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ [Int
0] forall a. a -> [a] -> [a]
: [forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= -Int
1) (forall a b. (a -> b) -> [a] -> [b]
map (FromNode
fromNode forall k a. Ord k => Map k a -> k -> a
M.!) (Map Vertex [Vertex]
predMap forall k a. Ord k => Map k a -> k -> a
M.! (ToNode
toNode forall a. Vector a -> Int -> a
! Int
i)))
| Int
i <- [Int
1..Int
sforall a. Num a => a -> a -> a
-Int
1]]
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 :: forall g.
Graph g =>
g -> Vertex -> Map Vertex (Set Vertex) -> Map Vertex (Set Vertex)
toPredecessor g
g Vertex
pre Map Vertex (Set Vertex)
m = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {k}. Ord k => k -> Map k (Set Vertex) -> Map k (Set Vertex)
addPred Map Vertex (Set Vertex)
m (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 = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Ord a => Set a -> Set a -> Set a
S.union k
suc (forall a. a -> Set a
S.singleton Vertex
pre)
refineIDom :: Preds -> IDom -> IDom
refineIDom :: Vector [Int] -> IDom -> IDom
refineIDom Vector [Int]
preds IDom
idom = 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 -> 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 forall a. Ord a => a -> a -> Ordering
`compare` Int
b of
Ordering
LT -> IDom -> Int -> Int -> Int
intersect IDom
idom Int
a (IDom
idom forall a. Vector a -> Int -> a
! Int
b)
Ordering
EQ -> Int
a
Ordering
GT -> IDom -> Int -> Int -> Int
intersect IDom
idom (IDom
idom forall a. Vector a -> Int -> a
! Int
a) Int
b
getDom :: ToNode -> IDom -> Vector [Vertex]
getDom :: ToNode -> IDom -> Vector [Vertex]
getDom ToNode
toNode IDom
idom = Vector [Vertex]
res
where
root :: [Vertex]
root = [ToNode
toNode forall a. Vector a -> Int -> a
! Int
0]
res :: Vector [Vertex]
res = forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ [Vertex]
root forall a. a -> [a] -> [a]
: [ToNode
toNode forall a. Vector a -> Int -> a
! Int
i forall a. a -> [a] -> [a]
: Vector [Vertex]
res forall a. Vector a -> Int -> a
! (IDom
idom forall a. Vector a -> Int -> a
! Int
i) | Int
i <- [Int
1..forall a. Vector a -> Int
V.length IDom
idom forall a. Num a => a -> a -> a
- Int
1]]
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
numberTree :: Int -> Tree a -> (Int, Tree Int)
numberTree :: forall a. Int -> Tree a -> (Int, Tree Int)
numberTree Int
n (Node a
_ [Tree a]
ts) = let (Int
n', [Tree Int]
ts') = forall a. Int -> [Tree a] -> (Int, [Tree Int])
numberForest (Int
nforall a. Num a => a -> a -> a
+Int
1) [Tree a]
ts
in (Int
n', forall a. a -> [Tree a] -> Tree a
Node Int
n [Tree Int]
ts')
numberForest :: Int -> [Tree a] -> (Int, [Tree Int])
numberForest :: forall a. 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') = forall a. Int -> Tree a -> (Int, Tree Int)
numberTree Int
n Tree a
t
(Int
n'', [Tree Int]
ts') = forall a. Int -> [Tree a] -> (Int, [Tree Int])
numberForest Int
n' [Tree a]
ts
in (Int
n'', Tree Int
t'forall a. a -> [a] -> [a]
:[Tree Int]
ts')
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