```-- Manipulate graphs for metadata generation
{-# LANGUAGE TupleSections #-}
( -- * 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 "impossible!"

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

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

```