Relations, Graphs and Trees

Snail.hs

{-# LANGUAGE TupleSections, FlexibleInstances #-}
-- Manipulate graphs for metadata generation
--  WARNING: everything in here is REALLY REALLY REALLY SLOW
--
module Snail
       ( Rel(..)
       , fromList, toList
       , allR, differenceR, unionR, composeR, transitiveR
       , transClosure

       , UG(..)
       , DAG(..)
       , transReduction
       , transOrientation,    transOrientation'
       , minimumCompletion
       , partitionDAG

       , Tree(..)
       , sources, anchor )
where

import Data.List          hiding (partition)
import Data.Ord
import Data.Tuple
import Data.Maybe
import Control.Monad
import Control.Applicative
import Control.Arrow


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

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 ]


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


-- | Find the transitive reduction of a finite binary relation
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 ---------------------------------------------------------------------
newtype UG  a = UG (Dom a, Rel a)
newtype DAG a = DAG (Dom a, Rel a)

instance Show a => Show (UG a) where
  show (UG (d,r)) = "UG (" ++ (show d) ++ ", " ++ (show $ toList d r) ++ ")"

instance Show a => Show (DAG a) where
  show (DAG (d,r)) = "DAG (" ++ (show d) ++ ", " ++ (show $ toList d r) ++ ")"


-- | Find the transitive orientation of an undirected graph if one exists
--    using exponential-time bruteforce.
--    TODO implement O(n) algorithm
--
transOrientation :: Eq a => UG a -> Maybe (DAG a)
transOrientation (UG (d,g))
 = case toList d g of
        [] -> Just (DAG (d,g))
        edges 
          -> let  -- Treat G as a directed graph. For all subsets S of A (set of arcs),
                  --   reverse the direction of all arcs in S and check if the result
                  --   is transitive.
                  combo k      = filter ((k==) . length) $ subsequences edges
                  choices      = concatMap combo [1..length d]
                  choose c     = g `differenceR` fromList c
                                   `unionR`      fromList (map swap c)
              in  liftM DAG $ liftM (d,) $ find (transitiveR d) $ map choose choices


-- | Find the best transitive orientation possible, adding edges if necessary
transOrientation' :: (Show a, Eq a) => UG a -> DAG a
transOrientation' = fromJust . transOrientation . minimumCompletion


-- | Compute the minimum comparability completion of an undirected graph
--    (i.e. the minimum set of added edges to make the graph
--     transitively orientable)
--    using exponential-time bruteforce (this is NP hard).
--    probably DP-able
--
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

sources :: Eq a => a -> Tree a -> [a]
sources x (Tree (d, r)) = [y | y <- d, r y x]


-- | Partition a DAG into the minimum set of (directed) trees
--      once again with bruteforce (this is also NP hard).
--      There always exists a partition, in the worst case 
--      all nodes are disjoint
partitionDAG :: Eq a => DAG a -> [Tree a]
partitionDAG (DAG (d,g))
 = let edgesFor nodes  = [ (x,y) | x <- nodes, y <- nodes, g x y ]    
       mkGraph  nodes  = (nodes, fromList $ edgesFor nodes)
   in map Tree $ fromMaybe (error "partitionDAG: no partition found!") 
               $ find (all $ uncurry isTree) 
               $ map (map mkGraph) 
               $ sortBy (comparing length)
               $ partitionings d

type SubList a   = [a]
type Partitioning a = [SubList 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
                 
        
-- | 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)

SnailCheck.hs

{-# LANGUAGE TupleSections, FlexibleInstances #-}
module QCGraph where

import Data.List
import Data.Maybe
import Control.Applicative

import Test.QuickCheck
import Snail


instance Arbitrary (UG Int) where
  arbitrary = sized $ \s -> 
    let dom = [0..s `min` magicLimit]
        domG = elements dom
    in  UG . (dom,) . curry . flip elem 
          <$> nub . filter (uncurry (/=)) 
          <$> listOf (lexicoOrder <$> tupleOf domG domG)

-- Unacceptable performance for anything bigger than 5 =(
magicLimit = 3
rootStart  = 42

tupleOf :: Gen a -> Gen b -> Gen (a,b)
tupleOf a b = (,) <$> a <*> b 

lexicoOrder :: Ord a => (a, a) -> (a, a)
lexicoOrder (a , b) | a < b     = (a , b)
                    | otherwise = (b , a) 


-- R+ must: smallest set that contains R and is transitive
--    TODO: find fast way to check "smallest" part
prop_trans_closure_correct :: UG Int -> Bool
prop_trans_closure_correct (UG (d, r))
  = let r'           = toList d r
        clo          = toList d $ transClosure d r
        superset s z = null [ (x,y) | x <- d, y <- d
                                    , (x,y) `elem` z
                                    , not $ (x,y) `elem` s ]
        transitive s = transitiveR d $ fromList s
    in     clo `superset` r'
        && transitive clo


-- There must always be a transitive orientation if we allow adding edges
--    since the worst case is a complete graph.
prop_orientation_total :: UG Int -> Bool
prop_orientation_total = isJust . transOrientation . minimumCompletion


-- The alias trees generated in the end must not imply some two things
--    are distinct while they alias in the original DDC alias graph.
prop_alias_safety :: UG Int -> Bool
prop_alias_safety g@(UG (d, aliasDDC))
  = null [ (x,y) | x <- d, y <- d
                 , aliasDDC x y
                 , not $ aliasLLVM x y ]
    where trees = snd $ mapAccumL (\r t -> (r+1, anchor r t)) rootStart 
                      $ partitionDAG $ transOrientation' g
          ascendants :: Int -> Tree Int -> [Int]
          ascendants x (Tree (ns, t))
            = let clo = transClosure ns t
              in  filter (clo x) ns
          descendants :: Int -> Tree Int -> [Int]
          descendants x t@(Tree (ns, _))  
            = [ y | y <- ns, x `elem` ascendants y t ]
          aliasLLVM x y 
            =    isNothing (find (\(Tree (ns,t)) -> x `elem` ns && y `elem` ns) trees)
              || any (\t -> y `elem` ((ascendants x t) ++ (descendants x t))) trees