« back to all changes in this revision
Viewing changes to cliquetree.ml
- browse files at revision 3
- compare with another revision
- download diff
- download tarball
- view history from revision 3
- Committer: Bazaar Package Importer
- Author(s): Sylvain Le Gall
- Date: 2005-03-23 23:17:46 UTC
- mfrom: (2.1.1 hoary)
- Revision ID: james.westby@ubuntu.com-20050323231746-8rmzgp3zyslg4me5
Tags: 0.90-2
* Transition to ocaml 3.08.3 : depends on ocaml-nox-3.08.3
* Patch 03_META use graph.cma and graph.cmxa ( Closes: #294806 )
* Correct the patch 01_makefile to install graph.a ( Closes: #289138 )
* Patch 03_META use graph.cma and graph.cmxa ( Closes: #294806 )
* Correct the patch 01_makefile to install graph.a ( Closes: #289138 )
- files added:
- cliquetree.ml
- files removed:
- sig.ml
- files modified:
- .depend
added
removed
cliquetree.ml
1
(**
2
Clique tree of a graph.
3
4
@author Matthieu Sozeau
5
*)
6
7
(*i $Id: cliquetree.ml,v 1.5 2004/10/20 09:59:56 signoles Exp $ i*)
8
9
module CliqueTree(Gr : Sig.G) = struct
10
11
(* Original vertex set (of Gr) *)
12
module OVSet = Set.Make(Gr.V)
13
14
(* Vertex signature *)
15
module rec CliqueV :
16
sig
17
type t
18
val compare : t -> t -> int
19
val hash : t -> int
20
val equal : t -> t -> bool
21
val label : t -> t
22
val create : Gr.V.t -> t
23
val vertex : t -> Gr.V.t
24
val number : t -> int
25
val set_number : t -> int -> unit
26
val clique : t -> int
27
val set_clique : t -> int -> unit
28
val mark : t -> int
29
val incr_mark : t -> unit
30
val m : t -> CVS.t
31
val set_m : t -> CVS.t -> unit
32
val last : t -> t
33
val set_last : t -> t -> unit
34
end =
35
struct
36
type t = {
37
mutable mark: int;
38
orig: Gr.V.t;
39
mutable m: CVS.t;
40
mutable last: t option;
41
mutable number: int;
42
mutable clique: int;
43
}
44
45
let compare x y = Gr.V.compare x.orig y.orig
46
let hash x = Gr.V.hash x.orig
47
let equal x y = Gr.V.equal x.orig y.orig
48
49
type label = t
50
let label x = x
51
52
let create o = {
53
mark = 0;
54
orig = o;
55
m = CVS.empty;
56
last = None;
57
number = 0;
58
clique = -1;
59
}
60
61
let vertex x = x.orig
62
63
let clique x = x.clique
64
let set_clique x v = x.clique <- v
65
66
let number x = x.number
67
let set_number x v = x.number <- v
68
69
let mark x = x.mark
70
let incr_mark x =
71
(*Printf.printf "Increasing mark of %s to %i\n%!"
72
(Gr.v_to_string x.orig) (succ x.mark);*)
73
x.mark <- succ x.mark
74
75
let m x = x.m
76
let set_m x v = x.m <- v
77
78
let last x =
79
match x.last with
80
Some v -> v
81
| None -> failwith "last not set"
82
83
let set_last x v = x.last <- Some v
84
85
end
86
(* Clique tree vertex set *)
87
and CVS : Set.S with type elt = CliqueV.t = Set.Make(CliqueV)
88
89
(* The final clique tree vertex type:
90
- set of original vertexes ordered by mark.
91
- clique number.
92
*)
93
module CliqueTreeV =
94
Util.DataV
95
(struct type t = CliqueV.t list * CVS.t end)
96
(struct
97
type t = int
98
type label = int
99
let compare x y = Pervasives.compare x y
100
let hash = Hashtbl.hash
101
let equal x y = x = y
102
let label x = x
103
let create lbl = lbl
104
end)
105
106
module CliqueTreeE = struct
107
type t = int * CVS.t
108
109
let compare (x, _) (y, _) = Pervasives.compare x y
110
111
let default = (0, CVS.empty)
112
113
let create n s = (n, s)
114
115
let vertices = snd
116
117
let width g tri (_, x) =
118
let vertices = List.map CliqueV.vertex (CVS.elements x) in
119
let w =
120
List.fold_left
121
(fun w v ->
122
List.fold_left
123
(fun w v' ->
124
if v <> v' then
125
if not (Gr.mem_edge g v v') && Gr.mem_edge tri v v'
126
then succ w
127
else w
128
else w)
129
w vertices)
130
0 vertices
131
in
132
assert(w mod 2 = 0);
133
w / 2
134
end
135
136
(* The returned tree *)
137
module CliqueTree =
138
Persistent.Digraph.ConcreteLabeled(CliqueTreeV)(CliqueTreeE)
139
140
(* Intermediate graph *)
141
module G = Persistent.Graph.Concrete(CliqueV)
142
143
(* Convenient types *)
144
module EdgeSet = Set.Make(G.E)
145
module H = Hashtbl.Make(CliqueV)
146
147
(* Used to choose some vertex in the intermediate graph *)
148
module Choose = Oper.Choose(G)
149
150
(* Creates the intermediate graph from the original *)
151
module Copy = Gmap.Vertex(Gr)(struct include G include Builder.P(G) end)
152
153
open CliqueV
154
155
let vertices_list x =
156
let l = CVS.elements x in
157
List.sort
158
(fun x y ->
159
let markx = mark x and marky = mark y in
160
- Pervasives.compare (number x) (number y))
161
l
162
163
let mcs_clique g =
164
(* initializations *)
165
let n = Gr.nb_vertex g in
166
let f = EdgeSet.empty in
167
let g' = Copy.map CliqueV.create g in
168
let unnumbered = ref (G.fold_vertex CVS.add g' CVS.empty) in
169
let pmark = ref (-1) in
170
let order = ref [] in
171
let cliques = Array.make n ([], CVS.empty) in
172
let ties = ref [] in
173
let j = ref 0 in
174
(* loop, taking each unnumbered vertex in turn *)
175
for i = n downto 1 do
176
(* Find greatest unnumbered vertex
177
if CVS.is_empty !unnumbered then
178
Printf.printf "No more unnumbered vertices\n%!"
179
else
180
Printf.printf "%i unnumbered vertices remaining\n%!"
181
(CVS.cardinal !unnumbered);
182
*)
183
let x, mark =
184
let choosed = CVS.choose !unnumbered in
185
CVS.fold
186
(fun x ((maxx, maxv) as max) ->
187
let v = mark x in
188
if v > maxv then (x, v) else max)
189
!unnumbered (choosed, mark choosed)
190
in
191
(* peo construction *)
192
order := x :: !order;
193
(* now numbered *)
194
unnumbered := CVS.remove x !unnumbered;
195
if mark <= !pmark then begin
196
(* Create a new clique (lemma 8) *)
197
incr j;
198
(* m x is the neighborhoud of x in the previous clique *)
199
cliques.(!j) <- ([x], CVS.add x (m x));
200
(* Use reverse map of cliques to find what clique
201
we're connected to. m x is the width of the ties *)
202
let clast = clique (last x) in
203
ties := (clast, m x, !j) :: !ties;
204
end else begin
205
let l, c = cliques.(!j) in
206
cliques.(!j) <- (x::l, CVS.add x c);
207
end;
208
G.iter_succ
209
(fun y ->
210
if number y == 0 then begin
211
incr_mark y;
212
set_m y (CVS.add x (m y));
213
end;
214
set_last y x)
215
g' x;
216
pmark := mark;
217
set_number x i;
218
set_clique x !j;
219
done;
220
let cliques =
221
Array.mapi
222
(fun i (l, c) -> CliqueTreeV.create (List.rev l, c) i)
223
(Array.sub cliques 0 (succ !j))
224
in
225
let tree =
226
Array.fold_left CliqueTree.add_vertex CliqueTree.empty cliques
227
in
228
let tree, _ =
229
List.fold_left
230
(fun (g, n) (i, verts, j) ->
231
let label = CliqueTreeE.create n verts in
232
let edge = CliqueTree.E.create cliques.(i) label cliques.(j) in
233
(CliqueTree.add_edge_e g edge, succ n))
234
(tree, 1) !ties
235
in
236
List.map CliqueV.vertex !order, tree, cliques.(0)
237
238
let sons g x = CliqueTree.fold_succ (fun x y -> x :: y) g x []
239
240
exception NotClique
241
242
let rec drop_while p l =
243
match l with
244
| x :: tl ->
245
if p x then drop_while p tl
246
else l
247
| [] -> []
248
249
let test_simpliciality_first l sons =
250
let takeOne l = match !l with
251
| x :: xs -> l := xs; Some x
252
| [] -> None
253
in
254
let put l x = l := x :: !l in
255
let vertices = ref l in
256
let sons = ref sons in
257
try
258
while !vertices <> [] && not (List.for_all (fun c -> !c = []) !sons) do
259
(match takeOne vertices with
260
Some v ->
261
let mark = CliqueV.mark v in
262
List.iter
263
(fun s ->
264
match !s with
265
| y :: tl ->
266
let ymark = CliqueV.mark y in
267
if ymark > mark then
268
()
269
else if ymark = mark then
270
s := drop_while
271
(fun y -> CliqueV.mark y = mark) tl
272
else raise NotClique
273
| [] -> ())
274
!sons
275
| None -> assert false);
276
done;
277
!vertices <> []
278
with NotClique -> false
279
280
let test_simpliciality_first' l sons =
281
List.for_all
282
(fun son ->
283
match !son with
284
| [] -> false
285
| xi :: tl ->
286
let other = m xi in
287
CVS.subset other l)
288
sons
289
290
let test_simpliciality_next vertices sons =
291
match vertices with
292
| x :: tl ->
293
begin
294
try
295
ignore(
296
List.fold_left
297
(fun vm v' ->
298
let vm' = CliqueV.m v' in
299
if CVS.equal vm' vm then
300
CVS.add v' vm'
301
else raise NotClique)
302
(CVS.add x (m x)) tl);
303
true
304
with NotClique -> false
305
end
306
| _ -> true
307
308
let is_chordal g =
309
let order, tree, root = mcs_clique g in
310
let rec aux c =
311
let csons = sons tree c in
312
let s = List.map CliqueTreeV.data csons in
313
let l = CliqueTreeV.data c in
314
let sons () = List.map (fun (x,y) -> ref x) s in
315
let first = test_simpliciality_first' (snd l) (sons ()) in
316
let next = test_simpliciality_next (fst l) (sons ()) in
317
first && next && (List.for_all aux csons)
318
in
319
aux root
320
321
let maxwidth g tri tree =
322
CliqueTree.fold_edges_e
323
(fun e res ->
324
let w = CliqueTreeE.width g tri (CliqueTree.E.label e) in
325
max res w)
326
tree 0
327
328
end
Loggerhead is a web-based interface for Breezy
Version: 2.0.1