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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
|
(* Co-installability tools
* http://coinst.irill.org/
* Copyright (C) 2010-2011 Jérôme Vouillon
* Laboratoire PPS - CNRS Université Paris Diderot
*
* These programs are free software; you can redistribute them and/or
* modify them under the terms of the GNU General Public License as
* published by the Free Software Foundation; either version 2 of the
* License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see <http://www.gnu.org/licenses/>.
*)
module F (R : Repository.S) = struct
open R
module Quotient = Quotient.F(R)
module Conflicts = Conflicts.F (R)
let output
?options
?package_weight
?package_emph
?(edge_color = fun _ _ _ -> Some "blue") ?(grayscale =false)
file ?(mark_all = false) ?(mark_reversed = false) ?(roots = [])
quotient deps confl =
let package_weight =
match package_weight with
Some f -> f
| None -> fun p -> float (Quotient.class_size quotient p)
in
let package_emph =
match package_emph with
Some f -> f
| None -> fun p -> false
in
let confl_style = if grayscale then ",style=dashed" else ",color=red" in
let confl_clique_style =
if grayscale then "" else ",color=red,fontcolor=red" in
let dep_style col = if grayscale then "" else Format.sprintf "color=%s" col in
let disj_dep_style col =
if grayscale then "" else Format.sprintf "fontcolor=%s,color=%s" col col in
(* Mark the packages to be included in the graph *)
let marks = Hashtbl.create 101 in
let marked i = Hashtbl.mem marks i in
let has_dependencies p =
let dep = PTbl.get deps p in
not (Formula.implies Formula._true dep ||
Formula.implies (Formula.lit p) dep)
in
let rec mark p =
if not (marked p) then begin
Hashtbl.add marks p ();
PSet.iter mark (Conflict.of_package confl p)
end
in
if mark_all then
Quotient.iter (fun p -> Hashtbl.add marks p ()) quotient
else if roots = [] then begin
Quotient.iter
(fun p ->
if has_dependencies p then begin
mark p;
Formula.iter (PTbl.get deps p) (fun d -> Disj.iter d mark)
end)
quotient;
if mark_reversed then begin
let m = Hashtbl.copy marks in
Hashtbl.clear marks;
Quotient.iter
(fun p -> if not (Hashtbl.mem m p) then Hashtbl.add marks p ())
quotient
end
end else (*XXX Find the right algorithm...
Work on transitive closure of dependencies
Mark all conflicts; marks all packages at the other side of
these conflicts and all the alternative in the dependency.
Proceed recursively...
Backward mode:
mark source package and all edges but the one considered
A package is not relevant if installing it or not has no
impact on the considered package
*)
List.iter mark roots;
let dep_targets = ref PSet.empty in
Quotient.iter
(fun p ->
Formula.iter (PTbl.get deps p)
(fun d ->
Disj.iter d
(fun q ->
if p <> q then dep_targets := PSet.add q !dep_targets)))
quotient;
let ch = open_out file in
let f = Format.formatter_of_out_channel ch in
Format.fprintf f "digraph G {@.";
begin match options with
None ->
Format.fprintf f "rankdir=LR;@.";
Format.fprintf f "ratio=1.4;@.margin=5;@.ranksep=3;@."
| Some l ->
List.iter (fun s -> Format.fprintf f "%s@." s) l
end;
Format.fprintf f "node [style=rounded];@.";
let confl_n = ref 0 in
Conflict.iter confl
(fun p q ->
if not (marked p) then begin
assert (not (marked q));
Conflict.remove confl p q
end);
let l = Conflicts.f quotient confl in
List.iter
(fun cset ->
match PSet.elements cset with
[i; j] ->
if
PSet.mem j !dep_targets && not (PSet.mem i !dep_targets)
then
Format.fprintf f "%d -> %d [dir=none%s];@."
(Package.index j) (Package.index i) confl_style
else
Format.fprintf f "%d -> %d [dir=none%s];@."
(Package.index i) (Package.index j) confl_style
| l ->
incr confl_n;
let n = !confl_n in
Format.fprintf f
"confl%d [label=\"#\",shape=circle%s];@."
n confl_clique_style;
List.iter
(fun i ->
Format.fprintf f
"%d -> confl%d [dir=none%s];@."
(Package.index i) n confl_style)
l)
l;
let dep_tbl = Hashtbl.create 101 in
let dep_n = ref 0 in
let add_dep i dep d =
let s = Disj.to_lits d in
match edge_color i dep d with
None ->
()
| Some col ->
match PSet.cardinal s with
0 ->
incr dep_n;
let n = !dep_n in
Format.fprintf f
"dep%d \
[label=\"MISSING DEP\",shape=box,fontcolor=red,%s];@."
n (dep_style col);
Format.fprintf f "%d -> dep%d [%s];@."
(Package.index i) n (dep_style col)
| 1 ->
if PSet.choose s <> i then
Format.fprintf f "%d -> %d [minlen=2, weight=2, %s];@."
(Package.index i) (Package.index (PSet.choose s))
(dep_style col)
| _ ->
let n =
try
Hashtbl.find dep_tbl s
with Not_found ->
incr dep_n;
let n = !dep_n in
Hashtbl.add dep_tbl s n;
(*
Format.fprintf f "dep%d [label=\"DEP\",shape=box,color=%s];@."
n col;
*)
Format.fprintf f "dep%d [label=\"∨\",shape=circle,%s];@."
n (disj_dep_style col);
(*
Format.fprintf f "dep%d [label=\"or\",shape=circle,%s];@."
n (disj_dep_style col);
*)
PSet.iter
(fun j ->
Format.fprintf f "dep%d -> %d [%s];@."
n (Package.index j) (dep_style col))
s;
n
in
Format.fprintf f "%d -> dep%d [dir=none,%s];@."
(Package.index i) n (dep_style col)
in
Quotient.iter
(fun i ->
let dep = PTbl.get deps i in
if marked i then begin
let n = package_weight i in
let em = package_emph i in
let w = (min 1. (log n /. log 1000.)) in
let color =
if grayscale then
let c = 255 - truncate (w *. 255.9) in
Format.sprintf "#%02x%02x%02x" c c c
else
Format.sprintf "0.0,%f,1.0" w
in
Format.fprintf f
"%d [label=\"%a\",style=\"filled\",\
fillcolor=\"%s\"%s];@."
(Package.index i) (Quotient.print_class quotient) i
color
(if em then ",penwidth=1.7" else "");
Formula.iter dep (fun s -> add_dep i dep s)
end)
quotient;
Format.fprintf f "}@.";
close_out ch
end
|
