-- Manipulate graphs for metadata generation
--  WARNING: everything in here is REALLY SLOW
module DDC.Core.Llvm.Metadata.Graph
       ( -- * Graphs and Trees for TBAA metadata
         UG(..), DG(..)
       , minOrientation, partitionDG
       , Tree(..)
       , sources, anchor 

         -- * Quickcheck Testing ONLY
       , Dom, Rel
       , fromList, toList
       , allR, differenceR, unionR, composeR, transitiveR
       , transClosure, transReduction
       , aliasMeasure, isTree 
       , orientation, orientations
       , bruteforceMinOrientation
       , transOrientation
       , smallOrientation
       , partitionings       
       , minimumCompletion )
where
import Data.List          hiding (partition)
import Data.Ord
import Data.Tuple
import Data.Maybe
import Control.Monad


-- 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


-- | Get the size of a a relation.
size :: Dom a -> Rel a -> Int
size d r = length $ toList d r


-- | The universal negative relation.
--   All members of the domain are not related.
allR :: Eq a => Rel a
allR = (/=)


-- | Fifference of two relations.
differenceR :: Rel a -> Rel a -> Rel a
differenceR     f g = \x y -> f x y && not (g x y)


-- | Union two relations.
unionR :: Rel a -> Rel a -> Rel a
unionR          f g = \x y -> f x y || g x y


-- | Compose two relations.
composeR :: Dom a -> Rel a -> Rel a -> Rel a
composeR dom f g = \x y -> or [ f x z && g z y | z <- dom ]


-- | Check whether a relation is transitive.
transitiveR :: Dom a -> Rel a -> Bool
transitiveR dom r
 = and [ not (r x y  && r y z && not (r x z)) 
       | x <- dom, y <- dom, z <- dom ]


-- | 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])


-- | Get the size of the transitive closure of a relation.
transCloSize :: (Eq a) => Dom a -> Rel a -> Int
transCloSize d r = size d $ transClosure d r

transReduction :: Eq a => Dom a -> Rel a -> Rel a
transReduction dom rel 
  = let composeR' = composeR dom
    in  rel `differenceR` (rel `composeR'` transClosure dom rel)


-- 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 


-- | Find the transitive orientation of an undirected graph if one exists
---
--   ISSUE #297: Taking the transitive orientation of an aliasing graph
--    takes exponential(?) time. We should implement the O(n+m) algorithm
--    or detect when this is taking too long and bail out.
--
transOrientation :: Eq a => UG a -> Maybe (DG a)
transOrientation ug@(UG (d,_))
  = liftM DG 
  $ liftM (d,) 
  $ find (transitiveR d) 
  $ orientations ug

orientations :: Eq a => UG a -> [Rel a]
orientations (UG (d,g))
  = case toList d g of
        []    -> [g]
        edges -> let combo k      = filter ((k==) . length) $ subsequences edges
                     choices      = concatMap combo [0..length d]
                     choose c     = g `differenceR` fromList c
                                      `unionR`      fromList (map swap c)
                  in map choose choices


-- | Find the orientation with the smallest transitive closure
--
minOrientation :: (Show a, Eq a) => UG a -> DG a
minOrientation ug = fromMaybe (bruteforceMinOrientation ug) (transOrientation ug)

bruteforceMinOrientation :: (Show a, Eq a) => UG a -> DG a
bruteforceMinOrientation ug@(UG (d, _))
  = let minTransClo : _ = sortBy (comparing $ transCloSize d)
                        $ orientations ug
     in DG (d, minTransClo)


-- | Find the orientation with a `small enough' transitive closure
--
smallOrientation :: (Show a, Eq a) => UG a -> DG a
smallOrientation ug = fromMaybe (orientation ug) (transOrientation ug)

orientation :: Eq a => UG a -> DG a
orientation (UG (d,g)) = DG (d,g)


-- | Add a minimum number of edges to an undirected graph such that
--    it has a transitive orientation
--
minimumCompletion :: (Show a, Eq a) => UG a -> UG a
minimumCompletion (UG (d,g))
 = let 
       -- Let U be the set of all possible fill edges. For all subsets
       --   S of U, add S to G and see if the result is trans-orientable.
       u           = toList d $ allR `differenceR` g
       combo k     = filter ((k==) . length) $ subsequences u
       choices     = concatMap combo [0..length u]
       choose c    = g `unionR` fromList c

       -- There always exists a comparability completion for an undirected graph
       --   in the worst case it's the complete version of the graph.
       --   the result is minimum thanks to how `subsequences` and
       --   list comprehensions work.
   in  fromMaybe (error "minimumCompletion: no completion found!") 
                $ liftM UG 
                $ find (isJust . transOrientation . UG) $ map ((d,) . choose) choices


-- 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 :: Eq a => 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 "partitionDG: no partition found!") 
               $ find (all $ uncurry isTree) 
               $ map (map (mkGraph g)) 
               $ sortBy (comparing (aliasMeasure g))
               $ partitionings d


-- | A partitioning of a tree.
type Partitioning a = [SubList a]
type SubList a      = [a]


-- | 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. What is the complexity of this current version?
--
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


-- | 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
                 
        
-- | 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)