Skip to content

Commit 9763591

Browse files
backtrackingbacktracking
authored
Merge pull request #146 from backtracking/145-transitive-reduction-disconnects-graph
fixed transitive reduction
2 parents 75533f6 + 77abed6 commit 9763591

File tree

6 files changed

+132
-27
lines changed

6 files changed

+132
-27
lines changed

‎CHANGES.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,8 @@
11

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
26
- [Graphviz]: added `PosPinned` to type `NeatoAttributes.vertex`
37
- [Oper]: improved efficiency of `intersect`
48
(#136, reported by Ion Chirica)

‎examples/depend2dot.ml‎

Lines changed: 65 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,65 @@
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

‎examples/dune‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
(executables
2-
(names color compare_prim_kruskal demo_planar demo_prim demo sudoku)
2+
(names color compare_prim_kruskal demo_planar demo_prim demo sudoku depend2dot)
33
(libraries graph unix graphics threads))
44

55
(alias

‎src/oper.ml‎

Lines changed: 38 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -99,30 +99,46 @@ module Make(B : Builder.S) = struct
9999
in
100100
add g1 (B.copy g2)
101101

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 =
104105
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
124137
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
126142

127143
let transitive_reduction ?(reflexive=false) g0 =
128144
replace_by_transitive_reduction ~reflexive (B.copy g0)

‎src/oper.mli‎

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -34,9 +34,14 @@ module type S = sig
3434
(then acts as [transitive_closure]). *)
3535

3636
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. *)
4045

4146
val replace_by_transitive_reduction : ?reflexive:bool -> g -> g
4247
(** [replace_by_transitive_reduction ?reflexive g] replaces [g] by its

‎tests/check.ml‎

Lines changed: 16 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -756,17 +756,22 @@ module Test_reduction = struct
756756

757757
let check_included g1 g2 =
758758
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
760760

761761
let check_same_graph g1 g2 =
762762
check_included g1 g2;
763763
check_included g2 g1
764764

765765
let test v e =
766+
(* Format.eprintf "v=%d e=%d@." v e; *)
766767
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; *)
767770
let t = O.transitive_closure g in
768771
check_included g t;
769772
let r = O.transitive_reduction g in
773+
(* Format.eprintf "r:@."; *)
774+
(* iter_edges (fun u v -> Format.eprintf " %d->%d@." u v) r; *)
770775
check_included r g;
771776
check_same_graph (O.transitive_closure r) t
772777

@@ -785,10 +790,20 @@ module Test_reduction = struct
785790
add_edge g 2 5;
786791
let r = O.transitive_reduction g in
787792
check_included r g;
793+
(* iter_edges (fun u v -> Format.eprintf " %d->%d@." u v) r; *)
788794
assert (nb_edges r = 4);
789795
assert (not (mem_edge r 2 5));
790796
()
791797

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)
806+
792807
end
793808

794809
let () = Format.printf "check: all tests succeeded@."

0 commit comments

Comments
 (0)