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