fixed transitive reduction

CHANGES.md

@@ -1,4 +1,8 @@
 
+  - [Oper] fixed transitive reduction (#145, reported by sim642)
+    and tests for transitive reduction!
+  - new example `depend2dot` to turn `make`-like dependencies
+    into a DOT graph, with transitive reduction
   - [Graphviz]: added `PosPinned` to type `NeatoAttributes.vertex`
   - [Oper]: improved efficiency of `intersect`
     (#136, reported by Ion Chirica)

examples/depend2dot.ml

@@ -0,0 +1,65 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Ocamlgraph: a generic graph library for OCaml                         *)
+(*  Copyright (C) 2004-2007                                               *)
+(*  Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles        *)
+(*                                                                        *)
+(*  This software is free software; you can redistribute it and/or        *)
+(*  modify it under the terms of the GNU Library General Public           *)
+(*  License version 2, with the special exception on linking              *)
+(*  described in file LICENSE.                                            *)
+(*                                                                        *)
+(*  This software is distributed in the hope that it will be useful,      *)
+(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
+(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                  *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Graph
+
+let usage () =
+  Format.eprintf "usage: depend2dot@.";
+  Format.eprintf "reads a dependency graph on the standard input, in format@.";
+  Format.eprintf "  a: b c d@.";
+  Format.eprintf "  b: c e@.";
+  Format.eprintf "  etc.@.";
+  Format.eprintf "and prints a reduced graph in DOT format on the standard output.@.";
+  exit 1
+
+module G = Imperative.Digraph.Abstract(String)
+module O = Oper.Make(Builder.I(G))
+module H = Hashtbl
+
+let graph = G.create ()
+
+let () =
+  let nodes = H.create 16 in
+  let node s = try H.find nodes s
+               with Not_found -> let v = G.V.create s in H.add nodes s v; v in
+  let node s = node (String.trim s) in
+  let add v w = if w <> "" then G.add_edge graph (node v) (node w) in
+  let add v w = add v w in
+  let parse_line s = match String.split_on_char ':' s with
+    | [v; deps] -> List.iter (add v) (String.split_on_char ' ' deps)
+    | [_] -> ()
+    | _ -> usage () in
+  let rec read () = match read_line () with
+    | s -> parse_line s; read ()
+    | exception End_of_file -> () in
+  read ()
+
+let graph = O.replace_by_transitive_reduction graph
+
+module Display = struct
+  include G
+  let vertex_name = V.label
+  let graph_attributes _ = []
+  let default_vertex_attributes _ = []
+  let vertex_attributes _ = []
+  let default_edge_attributes _ = []
+  let edge_attributes _ = []
+  let get_subgraph _ = None
+end
+module Dot = Graphviz.Dot(Display)
+
+let () = Dot.output_graph stdout graph

examples/dune

@@ -1,5 +1,5 @@
 (executables
- (names color compare_prim_kruskal demo_planar demo_prim demo sudoku)
+ (names color compare_prim_kruskal demo_planar demo_prim demo sudoku depend2dot)
  (libraries graph unix graphics threads))
 
 (alias

src/oper.ml

@@ -99,30 +99,46 @@ module Make(B : Builder.S) = struct
     in
     add g1 (B.copy g2)
 
-  let replace_by_transitive_reduction ?(reflexive=false) g0 =
-    (* first compute reachability in g0 using a DFS from each vertex *)
+  (* source: tred.c from Graphviz
+     time and space O(VE) *)
+  let replace_by_transitive_reduction ?(reflexive=false) g =
     let module H = Hashtbl.Make(G.V) in
-    let module D = Traverse.Dfs(G) in
-    let reachable = H.create (G.nb_vertex g0) in
-    let path_from v =
-      let s = H.create 8 in
-      H.add reachable v s;
-      D.prefix_component (fun w -> H.add s w ()) g0 v in
-    G.iter_vertex path_from g0;
-    let path u v = H.mem (H.find reachable u) v in
-    (* then remove redundant edges *)
-    let phi v g =
-      let g = if reflexive then B.remove_edge g v v else g in
-      G.fold_succ
-        (fun sv g ->
-           G.fold_succ
-             (fun sv' g ->
-                if not (G.V.equal sv sv') && path sv sv'
-                then B.remove_edge g v sv' else g)
-             g v g)
-        g v g
+    let reduce g v0 =
+      (* runs a DFS from v0 and records the length (=1 or >1) of paths from
+         v0 for reachable vertices *)
+      let nv = G.nb_vertex g in
+      let dist = H.create nv in
+      G.iter_vertex (fun w -> H.add dist w 0) g;
+      let update v w = H.replace dist w (1 + min 1 (H.find dist v)) in
+      let onstack = H.create nv in
+      let push v st = H.replace onstack v (); (v, G.succ g v) :: st in
+      let rec dfs = function
+        | [] -> ()
+        | (v, []) :: st ->
+            H.remove onstack v; dfs st
+        | (v, w :: sv) :: st when G.V.equal w v || H.mem onstack w ->
+            dfs ((v, sv) :: st)
+        | (v, w :: sv) :: st ->
+            if H.find dist w = 0 then (
+              update v w;
+              dfs (push w ((v, sv) :: st))
+            ) else (
+              if H.find dist w = 1 then update v w;
+              dfs ((v, sv) :: st)
+            ) in
+      dfs (push v0 []);
+      (* then delete any edge v0->v when the distance for v is >1 *)
+      let delete g v =
+        if G.V.equal v v0 && reflexive || H.find dist v > 1
+        then B.remove_edge g v0 v else g in
+      let sv0 = G.fold_succ (fun v sv0 -> v :: sv0) g v0 [] in
+      (* CAVEAT: iterate *then* modify *)
+      List.fold_left delete g sv0
     in
-    G.fold_vertex phi g0 g0
+    (* run the above from any vertex *)
+    let vl = G.fold_vertex (fun v vl -> v :: vl) g [] in
+    (* CAVEAT: iterate *then* modify *)
+    List.fold_left reduce g vl
 
   let transitive_reduction ?(reflexive=false) g0 =
     replace_by_transitive_reduction ~reflexive (B.copy g0)

src/oper.mli

@@ -34,9 +34,14 @@ module type S = sig
       (then acts as [transitive_closure]). *)
 
   val transitive_reduction : ?reflexive:bool -> g -> g
-  (** [transitive_reduction ?reflexive g] returns the transitive reduction
-      of [g] (as a new graph). Loops (i.e. edges from a vertex to itself)
-      are removed only if [reflexive] is [true] (default is [false]). *)
+  (** [transitive_reduction ?reflexive g] returns the transitive
+      reduction of [g] (as a new graph). This is a subgraph of [g]
+      with the same transitive closure as [g]. When [g] is acyclic,
+      its transitive reduction contains as few edges as possible and
+      is unique.
+      Loops (i.e. edges from a vertex to itself) are removed only if
+      [reflexive] is [true] (default is [false]).
+      Note: Only meaningful for directed graphs. *)
 
   val replace_by_transitive_reduction : ?reflexive:bool -> g -> g
   (** [replace_by_transitive_reduction ?reflexive g] replaces [g] by its

tests/check.ml

@@ -756,17 +756,22 @@ module Test_reduction = struct
 
   let check_included g1 g2 =
     iter_vertex (fun v -> assert (mem_vertex g2 v)) g1;
-    iter_edges (fun u v -> assert (mem_edge g1 u v)) g1
+    iter_edges (fun u v -> assert (mem_edge g2 u v)) g1
 
   let check_same_graph g1 g2 =
     check_included g1 g2;
     check_included g2 g1
 
   let test v e =
+    (* Format.eprintf "v=%d e=%d@." v e; *)
     let g = R.graph ~loops:true ~v ~e () in
+    (* Format.eprintf "g:@."; *)
+    (* iter_edges (fun u v -> Format.eprintf "  %d->%d@." u v) g; *)
     let t = O.transitive_closure g in
     check_included g t;
     let r = O.transitive_reduction g in
+    (* Format.eprintf "r:@."; *)
+    (* iter_edges (fun u v -> Format.eprintf "  %d->%d@." u v) r; *)
     check_included r g;
     check_same_graph (O.transitive_closure r) t
 
@@ -785,10 +790,20 @@ module Test_reduction = struct
     add_edge g 2 5;
     let r = O.transitive_reduction g in
     check_included r g;
+    (* iter_edges (fun u v -> Format.eprintf "  %d->%d@." u v) r; *)
     assert (nb_edges r = 4);
     assert (not (mem_edge r 2 5));
     ()
 
+  (* issue #145 *)
+  let () =
+    let g = create () in
+    for v = 1 to 3 do add_vertex g v done;
+    add_edge g 1 2; add_edge g 2 1;
+    add_edge g 3 1; add_edge g 3 2;
+    let r = O.transitive_reduction g in
+    check_same_graph (O.transitive_closure r) (O.transitive_closure g)
+
 end
 
 let () = Format.printf "check: all tests succeeded@."