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