The unpac monorepo manager self-hosting as a monorepo using unpac
Contraction: expose the underlying node mapping
+200
-3
+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
+88
tests/test_contraction.expected
+88
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;
19
+
0 -> 2;
20
+
1 -> 6;
21
+
2 -> 3;
22
+
2 -> 4;
23
+
3 -> 7;
24
+
4 -> 5;
25
+
5 -> 9;
26
+
6 -> 8;
27
+
7 -> 8;
28
+
9 -> 10;
29
+
10 -> 12;
30
+
12 -> 11;
31
+
32
+
}
33
+
digraph G {
34
+
0;
35
+
1;
36
+
3;
37
+
5;
38
+
6;
39
+
7;
40
+
9;
41
+
10;
42
+
11;
43
+
44
+
45
+
0 -> 1;
46
+
0 -> 3;
47
+
0 -> 5;
48
+
1 -> 6;
49
+
3 -> 7;
50
+
5 -> 9;
51
+
7 -> 6;
52
+
9 -> 10;
53
+
10 -> 11;
54
+
55
+
}
56
+
57
+
# union-find sets
58
+
0 -> {0, 2, 4}
59
+
1 -> {1}
60
+
2 -> {0, 2, 4}
61
+
3 -> {3}
62
+
4 -> {0, 2, 4}
63
+
5 -> {5}
64
+
6 -> {6, 8}
65
+
7 -> {7}
66
+
8 -> {6, 8}
67
+
9 -> {9}
68
+
10 -> {10, 12}
69
+
11 -> {11}
70
+
12 -> {10, 12}
71
+
13 -> {13}
72
+
73
+
# g -> g'
74
+
0 -> 0
75
+
1 -> 1
76
+
2 -> 0
77
+
3 -> 3
78
+
4 -> 0
79
+
5 -> 5
80
+
6 -> 6
81
+
7 -> 7
82
+
8 -> 6
83
+
9 -> 9
84
+
10 -> 10
85
+
11 -> 11
86
+
12 -> 10
87
+
13 -> 13
88
+
+76
tests/test_contraction.ml
+76
tests/test_contraction.ml
···
1
+
(* Test file for Contraction *)
2
+
3
+
open Graph
4
+
5
+
module Int = struct
6
+
type t = int
7
+
let compare = compare
8
+
let hash = Hashtbl.hash
9
+
let equal = (=)
10
+
let default = 0
11
+
end
12
+
13
+
module G = Persistent.Digraph.ConcreteBidirectional(Int)
14
+
15
+
(* Make a persistent graph where:
16
+
17
+
0---1---6
18
+
/ \
19
+
2---3---7---8
20
+
/
21
+
4---5---9---10---12---11 13
22
+
23
+
and contract edges linking even numbers.
24
+
25
+
1---6,8
26
+
/ /
27
+
4,2,0---3---7
28
+
\
29
+
5---9---10,12---11
30
+
31
+
*)
32
+
let g = List.fold_left (fun g (x, y) ->
33
+
G.add_edge g x y) (G.add_vertex G.empty 13) [
34
+
(0, 1); (1, 6);
35
+
(0, 2); (6, 8);
36
+
(2, 3); (3, 7); (7, 8);
37
+
(2, 4);
38
+
(4, 5); (5, 9); (9, 10); (10, 12); (12, 11)
39
+
]
40
+
41
+
module C = Contraction.Make(G)
42
+
43
+
let connects_even (src, dst) = (src mod 2 = 0) && (dst mod 2 = 0)
44
+
let g', m = C.contract' connects_even g
45
+
46
+
module Dot = Graphviz.Dot (
47
+
struct
48
+
include G
49
+
let vertex_name = string_of_int
50
+
let graph_attributes _ = []
51
+
let default_vertex_attributes _ = []
52
+
let vertex_attributes _ = []
53
+
let default_edge_attributes _ = []
54
+
let edge_attributes _ = []
55
+
let get_subgraph _ = None
56
+
end)
57
+
58
+
let _ = Dot.output_graph stdout g
59
+
let _ = Dot.output_graph stdout g'
60
+
61
+
let pp_comma fmt () = Format.fprintf fmt ",@ "
62
+
let pp_map pp_value fmt =
63
+
C.M.iter (fun x v -> Format.(fprintf fmt "%d -> %a@\n" x pp_value v))
64
+
let pp_set fmt s =
65
+
Format.fprintf fmt "@[<hv>{%a}@]"
66
+
Format.(pp_print_list ~pp_sep:pp_comma pp_print_int)
67
+
(C.S.elements s)
68
+
69
+
let make_map_to_contracted = C.M.map C.S.min_elt
70
+
71
+
let _ =
72
+
Format.open_vbox 0;
73
+
Format.(printf "@\n# union-find sets@\n%a@\n" (pp_map pp_set) m);
74
+
Format.(printf "# g -> g'@\n%a@\n" (pp_map pp_print_int) (make_map_to_contracted m));
75
+
Format.close_box ()
76
+