1{- 2 3Copyright (c) 2014 Joachim Breitner 4 5A data structure for undirected graphs of variables 6(or in plain terms: Sets of unordered pairs of numbers) 7 8 9This is very specifically tailored for the use in CallArity. In particular it 10stores the graph as a union of complete and complete bipartite graph, which 11would be very expensive to store as sets of edges or as adjanceny lists. 12 13It does not normalize the graphs. This means that g `unionUnVarGraph` g is 14equal to g, but twice as expensive and large. 15 16-} 17module UnVarGraph 18 ( UnVarSet 19 , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets 20 , delUnVarSet 21 , elemUnVarSet, isEmptyUnVarSet 22 , UnVarGraph 23 , emptyUnVarGraph 24 , unionUnVarGraph, unionUnVarGraphs 25 , completeGraph, completeBipartiteGraph 26 , neighbors 27 , hasLoopAt 28 , delNode 29 ) where 30 31import GhcPrelude 32 33import Id 34import VarEnv 35import UniqFM 36import Outputable 37import Bag 38import Unique 39 40import qualified Data.IntSet as S 41 42-- We need a type for sets of variables (UnVarSet). 43-- We do not use VarSet, because for that we need to have the actual variable 44-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. 45-- Therefore, use a IntSet directly (which is likely also a bit more efficient). 46 47-- Set of uniques, i.e. for adjancet nodes 48newtype UnVarSet = UnVarSet (S.IntSet) 49 deriving Eq 50 51k :: Var -> Int 52k v = getKey (getUnique v) 53 54emptyUnVarSet :: UnVarSet 55emptyUnVarSet = UnVarSet S.empty 56 57elemUnVarSet :: Var -> UnVarSet -> Bool 58elemUnVarSet v (UnVarSet s) = k v `S.member` s 59 60 61isEmptyUnVarSet :: UnVarSet -> Bool 62isEmptyUnVarSet (UnVarSet s) = S.null s 63 64delUnVarSet :: UnVarSet -> Var -> UnVarSet 65delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s 66 67mkUnVarSet :: [Var] -> UnVarSet 68mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs 69 70varEnvDom :: VarEnv a -> UnVarSet 71varEnvDom ae = UnVarSet $ ufmToSet_Directly ae 72 73unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet 74unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) 75 76unionUnVarSets :: [UnVarSet] -> UnVarSet 77unionUnVarSets = foldr unionUnVarSet emptyUnVarSet 78 79instance Outputable UnVarSet where 80 ppr (UnVarSet s) = braces $ 81 hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] 82 83 84-- The graph type. A list of complete bipartite graphs 85data Gen = CBPG UnVarSet UnVarSet -- complete bipartite 86 | CG UnVarSet -- complete 87newtype UnVarGraph = UnVarGraph (Bag Gen) 88 89emptyUnVarGraph :: UnVarGraph 90emptyUnVarGraph = UnVarGraph emptyBag 91 92unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph 93{- 94Premature optimisation, it seems. 95unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) 96 | s1 == s3 && s2 == s4 97 = pprTrace "unionUnVarGraph fired" empty $ 98 completeGraph (s1 `unionUnVarSet` s2) 99unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) 100 | s2 == s3 && s1 == s4 101 = pprTrace "unionUnVarGraph fired2" empty $ 102 completeGraph (s1 `unionUnVarSet` s2) 103-} 104unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) 105 = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ 106 UnVarGraph (g1 `unionBags` g2) 107 108unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph 109unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph 110 111-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } 112completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph 113completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 114 115completeGraph :: UnVarSet -> UnVarGraph 116completeGraph s = prune $ UnVarGraph $ unitBag $ CG s 117 118neighbors :: UnVarGraph -> Var -> UnVarSet 119neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g 120 where go (CG s) = (if v `elemUnVarSet` s then [s] else []) 121 go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ 122 (if v `elemUnVarSet` s2 then [s1] else []) 123 124-- hasLoopAt G v <=> v--v ∈ G 125hasLoopAt :: UnVarGraph -> Var -> Bool 126hasLoopAt (UnVarGraph g) v = any go $ bagToList g 127 where go (CG s) = v `elemUnVarSet` s 128 go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 129 130 131delNode :: UnVarGraph -> Var -> UnVarGraph 132delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g 133 where go (CG s) = CG (s `delUnVarSet` v) 134 go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) 135 136prune :: UnVarGraph -> UnVarGraph 137prune (UnVarGraph g) = UnVarGraph $ filterBag go g 138 where go (CG s) = not (isEmptyUnVarSet s) 139 go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) 140 141instance Outputable Gen where 142 ppr (CG s) = ppr s <> char '²' 143 ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 144instance Outputable UnVarGraph where 145 ppr (UnVarGraph g) = ppr g 146