module DDC.Core.Llvm.Metadata.Graph
(
UG(..), DG(..)
, minOrientation, partitionDG
, Tree(..)
, sources, anchor
, 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
type Rel a = a -> a -> Bool
type Dom a = [a]
toList :: Dom a -> Rel a -> [(a, a)]
toList dom r = [ (x, y) | x <- dom, y <- dom, r x y ]
fromList :: Eq a => [(a, a)] -> Rel a
fromList s = \x y -> (x,y) `elem` s
size :: Dom a -> Rel a -> Int
size d r = length $ toList d r
allR :: Eq a => Rel a
allR = (/=)
differenceR :: Rel a -> Rel a -> Rel a
differenceR f g = \x y -> f x y && not (g x y)
unionR :: Rel a -> Rel a -> Rel a
unionR f g = \x y -> f x y || g x y
composeR :: Dom a -> Rel a -> Rel a -> Rel a
composeR dom f g = \x y -> or [ f x z && g z y | z <- dom ]
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 ]
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])
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)
newtype UG a = UG (Dom a, Rel a)
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
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
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)
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)
minimumCompletion :: (Show a, Eq a) => UG a -> UG a
minimumCompletion (UG (d,g))
= let
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
in fromMaybe (error "minimumCompletion: no completion found!")
$ liftM UG
$ find (isJust . transOrientation . UG) $ map ((d,) . choose) choices
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) ++ ")"
isTree :: Dom a -> Rel a -> Bool
isTree dom r
= let neighbours x = filter (r x) dom
in all ((<=1) . length . neighbours) dom
sources :: Eq a => a -> Tree a -> [a]
sources x (Tree (d, r)) = [y | y <- d, r y x]
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
type Partitioning a = [SubList a]
type SubList a = [a]
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
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
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)