content: -- Manipulate graphs for metadata generation
  {-# LANGUAGE TupleSections #-}
  module DDC.Core.Llvm.Metadata.Graph
         ( -- * Graphs and Trees for TBAA metadata
           UG(..), DG(..)
         , orientUG, partitionDG
         , Tree(..)
         , sources, anchor 
  
           -- * Quickcheck Testing ONLY
         , Dom, Rel
         , fromList, toList
         , transClosure, transOrient
         , aliasMeasure, isTree )
  where
  import Data.List 
  import Data.Ord
  import Data.Maybe
  
  
  -- Binary relations -----------------------------------------------------------
  -- | A binary relation.
  type Rel a = a -> a -> Bool
  type Dom a = [a]
  
  
  -- | Convert a relation.
  toList :: Dom a -> Rel a -> [(a, a)]
  toList dom r = [ (x, y) | x <- dom, y <- dom, r x y ]
  
  
  -- | Convert a list to a relation.
  fromList :: Eq a => [(a, a)] -> Rel a
  fromList s = \x y -> (x,y) `elem` s
  
  
  -- | Union two relations.
  unionR :: Rel a -> Rel a -> Rel a
  unionR f g = \x y -> f x y || g x y
  
  
  -- | Find the transitive closure of a binary relation
  --      using Floyd-Warshall algorithm
  transClosure :: (Eq a) => Dom a -> Rel a -> Rel a
  transClosure dom r = fromList $ step dom $ toList dom r
      where step [] es     = es
            step (_:xs) es = step xs 
                            $ nub (es ++ [(a, d) 
                                  | (a, b) <- es
                                  , (c, d) <- es
                                  , b == c])
  
  
  -- Graphs ---------------------------------------------------------------------
  -- | An undirected graph.
  newtype UG  a = UG (Dom a, Rel a)
  
  -- | A directed graph.
  newtype DG  a = DG (Dom a, Rel a)
  
  instance Show a => Show (UG a) where
    show (UG (d,r)) = "UG (" ++ (show d) ++ ", fromList " ++ (show $ toList d r) ++ ")"
  
  instance Show a => Show (DG a) where
    show (DG (d,r)) = "DG (" ++ (show d) ++ ", fromList " ++ (show $ toList d r) ++ ")"
  
  instance Show a => Eq (DG a) where
    a == b = show a == show b 
  
  neighbourUG :: Rel a -> a -> a -> Bool
  neighbourUG f v x = f v x  || f x v
  
  
  -- | A partition (class) of vertices
  type Class a = [a]
  
  
  -- | Enforce an ordering on the relation of an undirected graph
  forceOrder :: Ord a => Class a -> Rel a -> Rel a 
  forceOrder ordering f 
    = let index = fromJust . (flip elemIndex ordering) 
      in  \x y -> neighbourUG f x y && index x < index y
  
  
  -- | Set of vertices is not a singleton or empty set
  nonSingleton :: Class a -> Bool
  nonSingleton []  = False
  nonSingleton [_] = False
  nonSingleton _   = True
  
                        
  -- | Use lexicographic breadth-first search on an undirected graph to produce an ordering
  --   of the vertices
  --              
  lexBFS :: (Show a, Ord a) => UG a -> Class a
  lexBFS (UG (vertices, f)) = refine [] [vertices]
    where refine acc classes
            | any nonSingleton classes = pivot acc classes
            | otherwise                = concat classes ++ acc
  
          pivot acc ([vertex]:classes)    = refine (vertex:acc) $ classes      `splitAllOn` vertex
          pivot acc ((vertex:vs):classes) = refine (vertex:acc) $ (vs:classes) `splitAllOn` vertex
          pivot _   _    = error "ddc-core-llvm.lexBFS: bogus warning suppression."
  
          splitAllOn [] _ = []
          splitAllOn (cl:classes) vertex
            | (neighbours, nonneighbours) <- partition (neighbourUG f vertex) cl
            , all (not . null) [neighbours, nonneighbours]
            = nonneighbours : neighbours : (classes `splitAllOn` vertex)
            | otherwise 
            = cl                         : (classes `splitAllOn` vertex)
  
  
  -- | Transitively orient an undireted graph
  --
  --   Using the algorithm from
  --   "Lex-BFS and partition refinement, with applications to transitive orientation, interval 
  --   graph recognition and consecutive ones testing", R. McConnell et al 2000
  --
  --   In the case where the transitive orientation does not exist, it simply gives some orientation
  --
  --   note: gave up on modular decomposition, this approach has very slightly worse time
  --         complexity but much simpler
  --   
  transOrient :: (Show a, Ord a) => UG a -> DG a
  transOrient g@(UG (vertices, f))
    = let vertices' = refine $ [(lexBFS g, maxBound)]
      in  DG (vertices, forceOrder vertices' f)
    where refine classes 
            | any nonSingleton $ map fst classes
            = let (before, after) = partition (\(c,lastused) -> length c > lastused `div` 2) classes
              in  refine (splitOthers before after)
            | otherwise = concatMap fst classes
          
          -- Split all other classes with respect to each member of a pivot class
          splitOthers before [] = splitLargest (largestClass before) before
          splitOthers before ((pivot,_):after)
            =    foldl' (split True) before pivot 
              ++ [(pivot, length pivot)] 
              ++ foldl' (split False) after pivot
  
          -- Split a class cl with regard to some vertex
          split _ [] _ = []
          split isBefore (cl:classes) vertex
            | (neighbours, nonneighbours) <- partition (neighbourUG f vertex) $ fst cl
            , all (not . null) [neighbours, nonneighbours]
            = let lastused = snd cl
              in  if   isBefore 
                  then (nonneighbours, lastused) : (neighbours,    lastused) 
                          : (split isBefore classes vertex)
                  else (neighbours,    lastused) : (nonneighbours, lastused) 
                          : (split isBefore classes vertex)
            | otherwise = cl:classes
  
          -- Split the largest class by the last vertex in the class found by lexBFS
          splitLargest _ [] = []
          splitLargest cl ((cs, lastused):css)
            | cl == cs  = (tail cs, lastused) : ([head cs], maxBound) : css
            | otherwise = (cs, lastused) : (splitLargest cl css)
  
          largestClass []      = []
          largestClass classes = maximumBy (comparing length) $ map fst classes
           
  
  orientUG :: (Show a, Ord a) => UG a -> DG a
  orientUG = transOrient
  
  
  -- | A vertex partitioning of a graph.
  type Partitioning a = [Class a]
  
  
  -- | Generate all possible partitions of a list
  --    by nondeterministically decide which sublist to add an element to.
  partitionings :: Eq a => [a] -> [Partitioning a]
  partitionings []     = [[]]
  partitionings (x:xs) = concatMap (nondetPut x) $ partitionings xs
    where nondetPut :: a -> Partitioning a -> [Partitioning a]
          nondetPut y []     = [ [[y]] ]
          nondetPut y (l:ls) = let putHere  = (y:l):ls
                                   putLater = map (l:) $ nondetPut y ls
                                in putHere:putLater
  
  
  -- | Calculate the aliasing induced by a set of trees this includes aliasing
  --   within each of the trees and aliasing among trees.
  ---
  --   ISSUE #298: Need a more efficient way to compute the
  --     aliasing measure. Currently O(|V|^5)
  --
  aliasMeasure :: Eq a => Rel a -> Partitioning a -> Int
  aliasMeasure g p
   = (outerAliasing $ map length p) + (sum $ map innerAliasing p)
      where innerAliasing t = length $ toList t $ transClosure t g
            outerAliasing (l:ls) = l * (sum ls) + outerAliasing ls
            outerAliasing []     = 0    
  
  
  -- Trees ----------------------------------------------------------------------
  -- | An inverted tree (with edges going from child to parent)
  newtype Tree a = Tree (Dom a, Rel a)
  
  instance Show a => Show (Tree a) where
    show (Tree (d,r)) = "tree (" ++ (show d) ++ ", " ++ (show $ toList d r) ++ ")"
  
  
  -- | A relation is an (inverted) tree if each node has at most one outgoing arc
  isTree :: Dom a -> Rel a -> Bool
  isTree dom r 
    = let neighbours x = filter (r x) dom 
      in  all ((<=1) . length . neighbours) dom
  
  
  -- | Get the sources of a tree.
  sources :: a -> Tree a -> [a]
  sources x (Tree (d, r)) = [y | y <- d, r y x]
  
  
  -- | Partition a DG into the minimum set of (directed) trees
  --
  partitionDG :: Eq a => DG a -> [Tree a]
  partitionDG (DG (d,g))
   = let mkGraph  g' nodes = (nodes, fromList [ (x,y) | x <- nodes, y <- nodes, g' x y ])
     in map Tree $ fromMaybe (error "ddc-core-llvm.partitionDG: no partition found!") 
                 $ find (all $ uncurry isTree) 
                 $ map (map (mkGraph g)) 
                 $ sortBy (comparing (aliasMeasure g))
                 $ partitionings d
  
                      
  -- | Enroot a tree with the given root.
  anchor :: Eq a => a -> Tree a -> Tree a
  anchor root (Tree (d,g))
    = let leaves = filter (null . flip filter d . g) d
          arcs   = map (, root) leaves
      in  Tree (root:d, g `unionR` fromList arcs)
  
  