module Data.Graph.Inductive.Query.Dominators (dom, iDom) where
{ import Data.Graph.Inductive.Graph;
  import Data.Graph.Inductive.Query.DFS;
  import Data.Tree (Tree(..));
  import qualified Data.Tree as T;
  import Data.Array;
  import Data.IntMap (IntMap);
  import qualified Data.IntMap as I;
   
  iDom :: (Graph gr) => gr a b -> Node -> [(Node, Node)];
  iDom g root
    = let { (result, toNode, _) = idomWork g root} in
        map (\ (a, b) -> (toNode ! a, toNode ! b)) (assocs result);
   
  dom :: (Graph gr) => gr a b -> Node -> [(Node, [Node])];
  dom g root
    = let { (iDom, toNode, fromNode) = idomWork g root;
            dom' = getDom toNode iDom;
            nodes' = nodes g;
            rest = I.keys (I.filter (- 1 ==) fromNode)}
        in
        [(toNode ! i, dom' ! i) | i <- range (bounds dom')] ++
          [(n, nodes') | n <- rest];
   
  type Node' = Int;
   
  type IDom = Array Node' Node';
   
  type Preds = Array Node' [Node'];
   
  type ToNode = Array Node' Node;
   
  type FromNode = IntMap Node';
   
  idomWork ::
           (Graph gr) => gr a b -> Node -> (IDom, ToNode, FromNode);
  idomWork g root
    = let { trees@(~[tree]) = dff [root] g;
            (s, ntree) = numberTree 0 tree;
            iDom0 = array (1, s - 1) (tail $ treeEdges (- 1) ntree);
            fromNode
              = I.unionWith const
                  (I.fromList (zip (T.flatten tree) (T.flatten ntree)))
                  (I.fromList (zip (nodes g) (repeat (- 1))));
            toNode = array (0, s - 1) (zip (T.flatten ntree) (T.flatten tree));
            preds
              = array (1, s - 1)
                  [(i, filter (/= - 1) (map (fromNode I.!) (pre g (toNode ! i)))) |
                   i <- [1 .. s - 1]];
            iDom = fixEq (refineIDom preds) iDom0}
        in
        if null trees then error "Dominators.idomWork: root not in graph"
          else (iDom, toNode, fromNode);
   
  refineIDom :: Preds -> IDom -> IDom;
  refineIDom preds iDom = fmap (foldl1 (intersect iDom)) preds;
   
  intersect :: IDom -> Node' -> Node' -> Node';
  intersect iDom a b
    = case a `compare` b of
          { LT -> intersect iDom a (iDom ! b);
            EQ -> a;
            GT -> intersect iDom (iDom ! a) b};
   
  getDom :: ToNode -> IDom -> Array Node' [Node];
  getDom toNode iDom
    = let { res
              = array (0, snd (bounds iDom))
                  ((0, [toNode ! 0]) :
                     [(i, toNode ! i : res ! (iDom ! i)) | i <- range (bounds iDom)])}
        in res;
   
  numberTree :: Node' -> Tree a -> (Node', Tree Node');
  numberTree n (Node _ ts)
    = let { (n', ts') = numberForest (n + 1) ts} in (n', Node n ts');
   
  numberForest :: Node' -> [Tree a] -> (Node', [Tree Node']);
  numberForest n [] = (n, []);
  numberForest n (t : ts)
    = let { (n', t') = numberTree n t;
            (n'', ts') = numberForest n' ts}
        in (n'', t' : ts');
   
  treeEdges :: a -> Tree a -> [(a, a)];
  treeEdges a (Node b ts) = (b, a) : concatMap (treeEdges b) ts;
   
  fixEq :: (Eq a) => (a -> a) -> a -> a;
  fixEq f v
    | v' == v = v
    | otherwise = fixEq f v'
    where { v' = f v}}
