Skip to content

Commit bae8c70

Browse files
backtrackingbacktracking
committed
integrated patchs from Markus Weissmann
1 parent bea7162 commit bae8c70

File tree

6 files changed

+156
-2
lines changed

6 files changed

+156
-2
lines changed

‎CHANGES

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,9 @@
11

2+
o new module Contraction implementing edge contraction
3+
(contributed by Markus W. Weissmann)
4+
o Gmap: new function [filter_map] (contributed by Markus W. Weissmann)
25
o Topological: fix bug when a cycle depends on another cycle. That breaks
3-
compatibility: the input graph must implement Sig.COMPARABLE instead of
6+
compatibility: the input graph must implement Sig.COMPARABLE instead of
47
Sig.HASHABLE
58
o new module Topological.Make_stable to iterate over a graph in a **stable**
69
topological order. Stable means that the provided ordering only depends on

‎Makefile.in

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -71,7 +71,7 @@ CMO = version util blocks persistent imperative \
7171
delaunay builder classic rand oper \
7272
components path nonnegative traverse coloring topological kruskal flow \
7373
graphviz gml dot_parser dot_lexer dot pack \
74-
gmap minsep cliquetree mcs_m md strat fixpoint leaderlist
74+
gmap minsep cliquetree mcs_m md strat fixpoint leaderlist contraction
7575
CMO := $(LIB) $(patsubst %, $(SRCDIR)/%.cmo, $(CMO))
7676

7777
CMX = $(CMO:.cmo=.cmx)

‎src/contraction.ml

Lines changed: 79 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,79 @@
1+
(**************************************************************************)
2+
(* *)
3+
(* Ocamlgraph: a generic graph library for OCaml *)
4+
(* Copyright (C) 2004-2010 *)
5+
(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *)
6+
(* *)
7+
(* This software is free software; you can redistribute it and/or *)
8+
(* modify it under the terms of the GNU Library General Public *)
9+
(* License version 2.1, with the special exception on linking *)
10+
(* described in file LICENSE. *)
11+
(* *)
12+
(* This software is distributed in the hope that it will be useful, *)
13+
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
14+
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
15+
(* *)
16+
(**************************************************************************)
17+
18+
(* Copyright (c) 2012 Technische Universitaet Muenchen
19+
* Markus W. Weissmann <markus.weissmann@in.tum.de>
20+
* All rights reserved. *)
21+
22+
(* Edge contraction for directed, edge-labeled graphs *)
23+
24+
module type G = sig
25+
type t
26+
module V : Sig.COMPARABLE
27+
type vertex = V.t
28+
module E : Sig.EDGE with type vertex = vertex
29+
type edge = E.t
30+
31+
val empty : t
32+
val add_edge_e : t -> edge -> t
33+
val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a
34+
val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a
35+
end
36+
37+
module Make
38+
(G : G) =
39+
struct
40+
module M = Map.Make(G.V)
41+
module S = Set.Make(G.V)
42+
43+
let contract prop g =
44+
(* if the edge is to be removed (property = true):
45+
* make a union of the two union-sets of start and end node;
46+
* put this set in the map for all nodes in this set *)
47+
let f edge m =
48+
if prop edge then
49+
let s_src, s_dst = M.find (G.E.src edge) m, M.find (G.E.dst edge) m in
50+
let s = S.union s_src s_dst in
51+
S.fold (fun vertex m -> M.add vertex s m) s m
52+
else
53+
m
54+
in
55+
(* if the edge is to be kept, add it to the new graph, exchanging
56+
* the start and end node with the minimum element from the set of
57+
* to-be-unified nodes; 'minimum is an arbitrary choice: any
58+
* deterministic choice will do *)
59+
let add m edge g =
60+
if prop edge then
61+
g
62+
else
63+
let lookup n = S.min_elt (M.find n m) in
64+
G.add_edge_e g
65+
(G.E.create (lookup (G.E.src edge)) (G.E.label edge)
66+
(lookup (G.E.dst edge)))
67+
in
68+
(* initialize map with singleton-sets for every node (of itself) *)
69+
let m =
70+
G.fold_vertex (fun vertex m -> M.add vertex (S.singleton vertex) m)
71+
g M.empty
72+
in
73+
(* find all closures *)
74+
let m = G.fold_edges_e f g m in
75+
(* rewrite the node numbers to close the gaps *)
76+
G.fold_edges_e (add m) g G.empty
77+
78+
end
79+

‎src/contraction.mli

Lines changed: 49 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,49 @@
1+
(**************************************************************************)
2+
(* *)
3+
(* Ocamlgraph: a generic graph library for OCaml *)
4+
(* Copyright (C) 2004-2010 *)
5+
(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *)
6+
(* *)
7+
(* This software is free software; you can redistribute it and/or *)
8+
(* modify it under the terms of the GNU Library General Public *)
9+
(* License version 2.1, with the special exception on linking *)
10+
(* described in file LICENSE. *)
11+
(* *)
12+
(* This software is distributed in the hope that it will be useful, *)
13+
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
14+
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
15+
(* *)
16+
(**************************************************************************)
17+
18+
(* Copyright (c) 2012 Technische Universitaet Muenchen
19+
* Markus W. Weissmann <markus.weissmann@in.tum.de>
20+
* All rights reserved. *)
21+
22+
(** Edge contraction for directed, edge-labeled graphs *)
23+
24+
(* This algorithm should be extensible to undirected, unlabeled graphs! *)
25+
26+
(** Minimal graph signature for edge contraction algorithm *)
27+
module type G = sig
28+
type t
29+
module V : Sig.COMPARABLE
30+
type vertex = V.t
31+
module E : Sig.EDGE with type vertex = vertex
32+
type edge = E.t
33+
34+
val empty : t
35+
val add_edge_e : t -> edge -> t
36+
val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a
37+
val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a
38+
end
39+
40+
module Make
41+
(G : G) :
42+
sig
43+
val contract : (G.E.t -> bool) -> G.t -> G.t
44+
(** [contract p g] will perform edge contraction on the graph [g].
45+
The edges for which the property [p] holds/is true will get contracted:
46+
The resulting graph will not have these edges; the start- and end-node
47+
of these edges will get united. *)
48+
end
49+

‎src/gmap.ml

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,12 @@ module Vertex(G_Src : V_SRC)(G_Dst : V_DST ) = struct
5151
(fun x g -> G_Dst.add_vertex g (convert_vertex f x))
5252
g (G_Dst.empty ())
5353

54+
let filter_map f g =
55+
G_Src.fold_vertex
56+
(fun x g -> match f x with
57+
| Some e -> G_Dst.add_vertex g e
58+
| None -> g
59+
) g (G_Dst.empty ())
5460
end
5561

5662
(** {2 Mapping of edges} *)
@@ -85,6 +91,13 @@ module Edge(G_Src: E_SRC)(G_Dst: E_DST) = struct
8591
G_Src.fold_edges_e
8692
(fun x g -> G_Dst.add_edge_e g (convert_edge f x))
8793
g (G_Dst.empty ())
94+
95+
let filter_map f g =
96+
G_Src.fold_edges_e
97+
(fun x g -> match f x with
98+
| Some e -> G_Dst.add_edge_e g e
99+
| None -> g
100+
) g (G_Dst.empty ())
88101
end
89102

90103
(*

‎src/gmap.mli

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,11 @@ module Vertex(G_Src : V_SRC)(G_Dst : V_DST) : sig
4343
(** [map f g] applies [f] to each vertex of [g] and so builds a new graph
4444
based on [g] *)
4545

46+
val filter_map : (G_Src.V.t -> G_Dst.vertex option) -> G_Src.t -> G_Dst.t
47+
(** [filter_map f g] applies [f] to each vertex of [g] and so
48+
builds a new graph based on [g]; if [None] is returned by [f]
49+
the vertex is omitted in the new graph. *)
50+
4651
end
4752

4853
(** {2 Mapping of edges} *)
@@ -69,4 +74,9 @@ module Edge(G_Src: E_SRC)(G_Dst: E_DST) : sig
6974
(** [map f g] applies [f] to each edge of [g] and so builds a new graph
7075
based on [g] *)
7176

77+
val filter_map : (G_Src.E.t -> G_Dst.edge option) -> G_Src.t -> G_Dst.t
78+
(** [filter_map f g] applies [f] to each edge of [g] and so builds
79+
a new graph based on [g]; if [None] is returned by [f] the
80+
edge is omitted in the new graph. *)
81+
7282
end

0 commit comments

Comments
 (0)