anil.recoil.org
The unpac monorepo manager self-hosting as a monorepo using unpac
Merge pull request #147 from tbrk/contract
Contraction: expose the underlying node mapping
authored by
Jean-Christophe Filliatre
and committed by
GitHub
ee5d4bc7
97635915
+4
-2
src/contraction.ml
+4
-2
src/contraction.ml
···
40
40
module M = Map.Make(G.V)
41
41
module S = Set.Make(G.V)
42
42
43
-
let contract prop g =
43
+
let contract' prop g =
44
44
(* if the edge is to be removed (property = true):
45
45
* make a union of the two union-sets of start and end node;
46
46
* put this set in the map for all nodes in this set *)
···
73
73
(* find all closures *)
74
74
let m = G.fold_edges_e f g m in
75
75
(* rewrite the node numbers to close the gaps *)
76
-
G.fold_edges_e (add m) g G.empty
76
+
G.fold_edges_e (add m) g G.empty, m
77
+
78
+
let contract prop g = fst (contract' prop g)
77
79
78
80
end
79
81
+13
-1
src/contraction.mli
+13
-1
src/contraction.mli
···
40
40
module Make
41
41
(G : G) :
42
42
sig
43
+
module S : Set.S with type elt = G.vertex
44
+
module M : Map.S with type key = G.vertex
45
+
43
46
val contract : (G.E.t -> bool) -> G.t -> G.t
44
47
(** [contract p g] will perform edge contraction on the graph [g].
45
48
The edges for which the property [p] holds/is true will get contracted:
46
49
The resulting graph will not have these edges; the start- and end-node
47
-
of these edges will get united. *)
50
+
of these edges will get united. The result graph does not include nodes
51
+
with no incoming or outgoing edges. *)
52
+
53
+
(** As for {!contract} but additionally returns a mapping that associates
54
+
each node in the original graph to the set of nodes with which it is
55
+
contracted in the result graph. The minimum element of each such set
56
+
is used as the representative of the set in the result graph. Nodes
57
+
with no incoming or outgoing edges are present in the mapping even if
58
+
they are omitted from the result graph. *)
59
+
val contract' : (G.E.t -> bool) -> G.t -> G.t * S.t M.t
48
60
end
49
61
+19
tests/dune
+19
tests/dune
···
128
128
(modules test_johnson)
129
129
(libraries graph))
130
130
131
+
;; Rules for the Contraction test
132
+
133
+
(rule
134
+
(with-stdout-to
135
+
test_contraction.output
136
+
(run ./test_contraction.exe)))
137
+
138
+
(rule
139
+
(alias runtest)
140
+
(action
141
+
(progn
142
+
(diff test_contraction.expected test_contraction.output)
143
+
(echo "test_contraction: all tests succeeded.\n"))))
144
+
145
+
(executable
146
+
(name test_contraction)
147
+
(modules test_contraction)
148
+
(libraries graph))
149
+
131
150
;; Rules for the test_nontrivial_dom test
132
151
133
152
(rule
+90
tests/test_contraction.expected
+90
tests/test_contraction.expected
···
1
+
digraph G {
2
+
0;
3
+
1;
4
+
2;
5
+
3;
6
+
4;
7
+
5;
8
+
6;
9
+
7;
10
+
8;
11
+
9;
12
+
10;
13
+
11;
14
+
12;
15
+
13;
16
+
17
+
18
+
0 -> 1 [taillabel="0-1", ];
19
+
0 -> 2 [taillabel="0-2", ];
20
+
1 -> 6 [taillabel="1-6", ];
21
+
2 -> 3 [taillabel="2-3", ];
22
+
2 -> 4 [taillabel="2-4", ];
23
+
2 -> 5 [taillabel="2-5", ];
24
+
3 -> 7 [taillabel="3-7", ];
25
+
4 -> 5 [taillabel="4-5", ];
26
+
5 -> 9 [taillabel="5-9", ];
27
+
6 -> 8 [taillabel="6-8", ];
28
+
7 -> 8 [taillabel="7-8", ];
29
+
9 -> 10 [taillabel="9-10", ];
30
+
10 -> 12 [taillabel="10-12", ];
31
+
12 -> 11 [taillabel="12-11", ];
32
+
33
+
}
34
+
digraph G {
35
+
0;
36
+
1;
37
+
3;
38
+
5;
39
+
6;
40
+
7;
41
+
9;
42
+
10;
43
+
11;
44
+
45
+
46
+
0 -> 1 [taillabel="0-1", ];
47
+
0 -> 3 [taillabel="2-3", ];
48
+
0 -> 5 [taillabel="2-5", ];
49
+
0 -> 5 [taillabel="4-5", ];
50
+
1 -> 6 [taillabel="1-6", ];
51
+
3 -> 7 [taillabel="3-7", ];
52
+
5 -> 9 [taillabel="5-9", ];
53
+
7 -> 6 [taillabel="7-8", ];
54
+
9 -> 10 [taillabel="9-10", ];
55
+
10 -> 11 [taillabel="12-11", ];
56
+
57
+
}
58
+
59
+
# union-find sets
60
+
0 -> {0, 2, 4}
61
+
1 -> {1}
62
+
2 -> {0, 2, 4}
63
+
3 -> {3}
64
+
4 -> {0, 2, 4}
65
+
5 -> {5}
66
+
6 -> {6, 8}
67
+
7 -> {7}
68
+
8 -> {6, 8}
69
+
9 -> {9}
70
+
10 -> {10, 12}
71
+
11 -> {11}
72
+
12 -> {10, 12}
73
+
13 -> {13}
74
+
75
+
# g -> g'
76
+
0 -> 0
77
+
1 -> 1
78
+
2 -> 0
79
+
3 -> 3
80
+
4 -> 0
81
+
5 -> 5
82
+
6 -> 6
83
+
7 -> 7
84
+
8 -> 6
85
+
9 -> 9
86
+
10 -> 10
87
+
11 -> 11
88
+
12 -> 10
89
+
13 -> 13
90
+
+85
tests/test_contraction.ml
+85
tests/test_contraction.ml
···
1
+
(* Test file for Contraction *)
2
+
3
+
#use "topfind";;
4
+
#require "ocamlgraph";;
5
+
6
+
open Graph
7
+
8
+
module Int = struct
9
+
type t = int
10
+
let compare = compare
11
+
let hash = Hashtbl.hash
12
+
let equal = (=)
13
+
let default = 0
14
+
end
15
+
16
+
module String = struct
17
+
type t = string
18
+
let compare = compare
19
+
let default = ""
20
+
end
21
+
22
+
module G = Persistent.Digraph.ConcreteLabeled(Int)(String)
23
+
24
+
(* Make a persistent graph where:
25
+
26
+
0---1---6
27
+
/ \
28
+
2---3---7---8
29
+
/ \
30
+
4---5---9---10---12---11 13
31
+
32
+
and contract edges linking even numbers.
33
+
34
+
1---6,8
35
+
/ /
36
+
4,2,0---3---7
37
+
\\
38
+
5---9---10,12---11
39
+
40
+
*)
41
+
let g = List.fold_left (fun g -> G.add_edge_e g) (G.add_vertex G.empty 13) [
42
+
(0, "0-1", 1); (1, "1-6", 6);
43
+
(0, "0-2", 2); (6, "6-8", 8);
44
+
(2, "2-3", 3); (3, "3-7", 7); (7, "7-8", 8);
45
+
(2, "2-4", 4); (2, "2-5", 5);
46
+
(4, "4-5", 5); (5, "5-9", 9); (9, "9-10", 10);
47
+
(10, "10-12", 12); (12, "12-11", 11)
48
+
]
49
+
50
+
module C = Contraction.Make(G)
51
+
52
+
let connects_even (src, _, dst) = (src mod 2 = 0) && (dst mod 2 = 0)
53
+
let g', m = C.contract' connects_even g
54
+
55
+
module Dot = Graphviz.Dot (
56
+
struct
57
+
include G
58
+
let vertex_name = string_of_int
59
+
let graph_attributes _ = []
60
+
let default_vertex_attributes _ = []
61
+
let vertex_attributes _ = []
62
+
let default_edge_attributes _ = []
63
+
let edge_attributes (_, l, _) = [`Taillabel l]
64
+
let get_subgraph _ = None
65
+
end)
66
+
67
+
let _ = Dot.output_graph stdout g
68
+
let _ = Dot.output_graph stdout g'
69
+
70
+
let pp_comma fmt () = Format.fprintf fmt ",@ "
71
+
let pp_map pp_value fmt =
72
+
C.M.iter (fun x v -> Format.(fprintf fmt "%d -> %a@\n" x pp_value v))
73
+
let pp_set fmt s =
74
+
Format.fprintf fmt "@[<hv>{%a}@]"
75
+
Format.(pp_print_list ~pp_sep:pp_comma pp_print_int)
76
+
(C.S.elements s)
77
+
78
+
let make_map_to_contracted = C.M.map C.S.min_elt
79
+
80
+
let _ =
81
+
Format.open_vbox 0;
82
+
Format.(printf "@\n# union-find sets@\n%a@\n" (pp_map pp_set) m);
83
+
Format.(printf "# g -> g'@\n%a@\n" (pp_map pp_print_int) (make_map_to_contracted m));
84
+
Format.close_box ()
85
+