anil.recoil.org
The unpac monorepo manager self-hosting as a monorepo using unpac
Merge pull request #146 from backtracking/145-transitive-reduction-disconnects-graph
fixed transitive reduction
authored by
Jean-Christophe Filliatre
and committed by
GitHub
97635915
75533f69
+4
CHANGES.md
+4
CHANGES.md
···
1
1
2
+
- [Oper] fixed transitive reduction (#145, reported by sim642)
3
+
and tests for transitive reduction!
4
+
- new example `depend2dot` to turn `make`-like dependencies
5
+
into a DOT graph, with transitive reduction
2
6
- [Graphviz]: added `PosPinned` to type `NeatoAttributes.vertex`
3
7
- [Oper]: improved efficiency of `intersect`
4
8
(#136, reported by Ion Chirica)
+65
examples/depend2dot.ml
+65
examples/depend2dot.ml
···
1
+
(**************************************************************************)
2
+
(* *)
3
+
(* Ocamlgraph: a generic graph library for OCaml *)
4
+
(* Copyright (C) 2004-2007 *)
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, 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
+
open Graph
19
+
20
+
let usage () =
21
+
Format.eprintf "usage: depend2dot@.";
22
+
Format.eprintf "reads a dependency graph on the standard input, in format@.";
23
+
Format.eprintf " a: b c d@.";
24
+
Format.eprintf " b: c e@.";
25
+
Format.eprintf " etc.@.";
26
+
Format.eprintf "and prints a reduced graph in DOT format on the standard output.@.";
27
+
exit 1
28
+
29
+
module G = Imperative.Digraph.Abstract(String)
30
+
module O = Oper.Make(Builder.I(G))
31
+
module H = Hashtbl
32
+
33
+
let graph = G.create ()
34
+
35
+
let () =
36
+
let nodes = H.create 16 in
37
+
let node s = try H.find nodes s
38
+
with Not_found -> let v = G.V.create s in H.add nodes s v; v in
39
+
let node s = node (String.trim s) in
40
+
let add v w = if w <> "" then G.add_edge graph (node v) (node w) in
41
+
let add v w = add v w in
42
+
let parse_line s = match String.split_on_char ':' s with
43
+
| [v; deps] -> List.iter (add v) (String.split_on_char ' ' deps)
44
+
| [_] -> ()
45
+
| _ -> usage () in
46
+
let rec read () = match read_line () with
47
+
| s -> parse_line s; read ()
48
+
| exception End_of_file -> () in
49
+
read ()
50
+
51
+
let graph = O.replace_by_transitive_reduction graph
52
+
53
+
module Display = struct
54
+
include G
55
+
let vertex_name = V.label
56
+
let graph_attributes _ = []
57
+
let default_vertex_attributes _ = []
58
+
let vertex_attributes _ = []
59
+
let default_edge_attributes _ = []
60
+
let edge_attributes _ = []
61
+
let get_subgraph _ = None
62
+
end
63
+
module Dot = Graphviz.Dot(Display)
64
+
65
+
let () = Dot.output_graph stdout graph
+1
-1
examples/dune
+1
-1
examples/dune
+38
-22
src/oper.ml
+38
-22
src/oper.ml
···
99
99
in
100
100
add g1 (B.copy g2)
101
101
102
-
let replace_by_transitive_reduction ?(reflexive=false) g0 =
103
-
(* first compute reachability in g0 using a DFS from each vertex *)
102
+
(* source: tred.c from Graphviz
103
+
time and space O(VE) *)
104
+
let replace_by_transitive_reduction ?(reflexive=false) g =
104
105
let module H = Hashtbl.Make(G.V) in
105
-
let module D = Traverse.Dfs(G) in
106
-
let reachable = H.create (G.nb_vertex g0) in
107
-
let path_from v =
108
-
let s = H.create 8 in
109
-
H.add reachable v s;
110
-
D.prefix_component (fun w -> H.add s w ()) g0 v in
111
-
G.iter_vertex path_from g0;
112
-
let path u v = H.mem (H.find reachable u) v in
113
-
(* then remove redundant edges *)
114
-
let phi v g =
115
-
let g = if reflexive then B.remove_edge g v v else g in
116
-
G.fold_succ
117
-
(fun sv g ->
118
-
G.fold_succ
119
-
(fun sv' g ->
120
-
if not (G.V.equal sv sv') && path sv sv'
121
-
then B.remove_edge g v sv' else g)
122
-
g v g)
123
-
g v g
106
+
let reduce g v0 =
107
+
(* runs a DFS from v0 and records the length (=1 or >1) of paths from
108
+
v0 for reachable vertices *)
109
+
let nv = G.nb_vertex g in
110
+
let dist = H.create nv in
111
+
G.iter_vertex (fun w -> H.add dist w 0) g;
112
+
let update v w = H.replace dist w (1 + min 1 (H.find dist v)) in
113
+
let onstack = H.create nv in
114
+
let push v st = H.replace onstack v (); (v, G.succ g v) :: st in
115
+
let rec dfs = function
116
+
| [] -> ()
117
+
| (v, []) :: st ->
118
+
H.remove onstack v; dfs st
119
+
| (v, w :: sv) :: st when G.V.equal w v || H.mem onstack w ->
120
+
dfs ((v, sv) :: st)
121
+
| (v, w :: sv) :: st ->
122
+
if H.find dist w = 0 then (
123
+
update v w;
124
+
dfs (push w ((v, sv) :: st))
125
+
) else (
126
+
if H.find dist w = 1 then update v w;
127
+
dfs ((v, sv) :: st)
128
+
) in
129
+
dfs (push v0 []);
130
+
(* then delete any edge v0->v when the distance for v is >1 *)
131
+
let delete g v =
132
+
if G.V.equal v v0 && reflexive || H.find dist v > 1
133
+
then B.remove_edge g v0 v else g in
134
+
let sv0 = G.fold_succ (fun v sv0 -> v :: sv0) g v0 [] in
135
+
(* CAVEAT: iterate *then* modify *)
136
+
List.fold_left delete g sv0
124
137
in
125
-
G.fold_vertex phi g0 g0
138
+
(* run the above from any vertex *)
139
+
let vl = G.fold_vertex (fun v vl -> v :: vl) g [] in
140
+
(* CAVEAT: iterate *then* modify *)
141
+
List.fold_left reduce g vl
126
142
127
143
let transitive_reduction ?(reflexive=false) g0 =
128
144
replace_by_transitive_reduction ~reflexive (B.copy g0)
+8
-3
src/oper.mli
+8
-3
src/oper.mli
···
34
34
(then acts as [transitive_closure]). *)
35
35
36
36
val transitive_reduction : ?reflexive:bool -> g -> g
37
-
(** [transitive_reduction ?reflexive g] returns the transitive reduction
38
-
of [g] (as a new graph). Loops (i.e. edges from a vertex to itself)
39
-
are removed only if [reflexive] is [true] (default is [false]). *)
37
+
(** [transitive_reduction ?reflexive g] returns the transitive
38
+
reduction of [g] (as a new graph). This is a subgraph of [g]
39
+
with the same transitive closure as [g]. When [g] is acyclic,
40
+
its transitive reduction contains as few edges as possible and
41
+
is unique.
42
+
Loops (i.e. edges from a vertex to itself) are removed only if
43
+
[reflexive] is [true] (default is [false]).
44
+
Note: Only meaningful for directed graphs. *)
40
45
41
46
val replace_by_transitive_reduction : ?reflexive:bool -> g -> g
42
47
(** [replace_by_transitive_reduction ?reflexive g] replaces [g] by its
+16
-1
tests/check.ml
+16
-1
tests/check.ml
···
756
756
757
757
let check_included g1 g2 =
758
758
iter_vertex (fun v -> assert (mem_vertex g2 v)) g1;
759
-
iter_edges (fun u v -> assert (mem_edge g1 u v)) g1
759
+
iter_edges (fun u v -> assert (mem_edge g2 u v)) g1
760
760
761
761
let check_same_graph g1 g2 =
762
762
check_included g1 g2;
763
763
check_included g2 g1
764
764
765
765
let test v e =
766
+
(* Format.eprintf "v=%d e=%d@." v e; *)
766
767
let g = R.graph ~loops:true ~v ~e () in
768
+
(* Format.eprintf "g:@."; *)
769
+
(* iter_edges (fun u v -> Format.eprintf " %d->%d@." u v) g; *)
767
770
let t = O.transitive_closure g in
768
771
check_included g t;
769
772
let r = O.transitive_reduction g in
773
+
(* Format.eprintf "r:@."; *)
774
+
(* iter_edges (fun u v -> Format.eprintf " %d->%d@." u v) r; *)
770
775
check_included r g;
771
776
check_same_graph (O.transitive_closure r) t
772
777
···
785
790
add_edge g 2 5;
786
791
let r = O.transitive_reduction g in
787
792
check_included r g;
793
+
(* iter_edges (fun u v -> Format.eprintf " %d->%d@." u v) r; *)
788
794
assert (nb_edges r = 4);
789
795
assert (not (mem_edge r 2 5));
790
796
()
797
+
798
+
(* issue #145 *)
799
+
let () =
800
+
let g = create () in
801
+
for v = 1 to 3 do add_vertex g v done;
802
+
add_edge g 1 2; add_edge g 2 1;
803
+
add_edge g 3 1; add_edge g 3 2;
804
+
let r = O.transitive_reduction g in
805
+
check_same_graph (O.transitive_closure r) (O.transitive_closure g)
791
806
792
807
end
793
808