From 69fd491f0685b32f14410c33db74b0807be29e53 Mon Sep 17 00:00:00 2001 From: Jean-Christophe Filliatre Date: Sun, 29 Dec 2019 14:29:13 +0100 Subject: [PATCH] fixed transitive_reduction also fixed 'make check' (tests/check.ml was not run anymore) --- Makefile.in | 7 ++-- src/oper.ml | 20 +++++++-- tests/check.ml | 96 ++++++++++++++++++++++++++++++++++++++++--- tests/test.ml | 1 - tests/test_clique.ml | 29 ------------- tests/test_topsort.ml | 8 ++-- 6 files changed, 114 insertions(+), 47 deletions(-) delete mode 100644 tests/test_clique.ml diff --git a/Makefile.in b/Makefile.in index e0f0c019..2ab9b0a3 100644 --- a/Makefile.in +++ b/Makefile.in @@ -68,8 +68,9 @@ OCAMLGRAPH_LIB= unionfind heap bitv persistentQueue OCAMLGRAPH_LIB:=$(patsubst %, $(OCAMLGRAPH_LIBDIR)/%.cmo, $(OCAMLGRAPH_LIB)) CMO = util blocks persistent imperative \ - delaunay builder classic rand oper \ - components path nonnegative traverse coloring topological kruskal flow \ + delaunay builder classic rand \ + components path nonnegative traverse oper \ + coloring topological kruskal flow \ prim dominator graphviz gml dot_parser dot_lexer dot pack \ gmap minsep cliquetree mcs_m md strat fixpoint leaderlist contraction \ graphml merge mincut clique weakTopological chaoticIteration @@ -351,7 +352,7 @@ bin/testunix.opt: $(CMXA) myTest/testunix.ml $(OCAMLOPT) -unsafe -inline 100 -o $@ unix.cmxa $^ check: $(CMA) tests/check.ml bin/test-ts - ocaml -I . $(CMA) tests/test_clique.ml tests/check.ml + ocaml -I . $(CMA) tests/check.ml bin/test-ts 10 # Additional rules diff --git a/src/oper.ml b/src/oper.ml index 3bd5b3bf..c3ccaf81 100644 --- a/src/oper.ml +++ b/src/oper.ml @@ -89,6 +89,7 @@ module Make(B : Builder.S) = struct with Invalid_argument _ -> (* [v] not in [g2] *) g) + g1 (B.empty ()) let union g1 g2 = @@ -102,14 +103,25 @@ module Make(B : Builder.S) = struct add g1 (B.copy g2) let replace_by_transitive_reduction ?(reflexive=false) g0 = + (* first compute reachability in g0 using a DFS from each vertex *) + 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_pred - (fun pv g -> - if G.V.equal pv v || G.V.equal sv v then g - else B.remove_edge g pv sv) + 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 in diff --git a/tests/check.ml b/tests/check.ml index 52aa1a25..ef4d10ac 100644 --- a/tests/check.ml +++ b/tests/check.ml @@ -441,6 +441,7 @@ module Traversal = struct open Format let pre v = printf "pre %d@." (G.V.label v) let post v = printf "post %d@." (G.V.label v) + (* let () = printf "iter:@."; Dfs.iter_component ~pre ~post g w let () = printf "prefix:@."; Dfs.prefix_component pre g w let () = @@ -451,6 +452,7 @@ module Traversal = struct visit (Dfs.step it) in try visit (Dfs.start g) with Exit -> () + *) end @@ -488,7 +490,7 @@ module FF_Goldberg = struct end module FF = Flow.Ford_Fulkerson(G)(F) - module Gold = Flow.Goldberg(G)(F) + module Gold = Flow.Goldberg_Tarjan(G)(F) let () = assert (snd (FF.maxflow g 1 6) = 23); @@ -523,11 +525,11 @@ module FF_Goldberg = struct end module FF2 = Flow.Ford_Fulkerson(G2)(F2) - module Gold2 = Flow.Goldberg(G2)(F2) + module Gold2 = Flow.Goldberg_Tarjan(G2)(F2) let () = - assert (snd (FF2.maxflow g 1 4) = 2); - assert (snd (Gold2.maxflow g 1 4) = 2) + assert (snd (FF2.maxflow g 1 4) = 2); (* growth of the flow *) + assert (snd (Gold2.maxflow g 1 4) = 3) (* max flow *) end @@ -679,7 +681,7 @@ module type RightSigPack = sig end val shortest_path : t -> V.t -> V.t -> E.t list * int val ford_fulkerson : t -> V.t -> V.t -> (E.t -> int) * int - val goldberg : t -> V.t -> V.t -> (E.t -> int) * int + val goldberg_tarjan : t -> V.t -> V.t -> (E.t -> int) * int val dot_output : t -> string -> unit end @@ -688,7 +690,89 @@ module TestSigPack : RightSigPack = struct type g = t end -include Test_clique +module Test_clique = struct + (* Test file for Brom-Kerbosch *) + + open Graph + + module G = Persistent.Graph.Concrete (struct + type t = int + let compare = compare + let hash = Hashtbl.hash + let equal = (=) + end) + + module BK = Clique.Bron_Kerbosch(G) + + let () = + let vertices = [1;2;3;4;5;6;7] in + let edges = [(1,2);(1,5);(2,5);(2,3);(4,5);(3,4);(4,6)] in + let g = List.fold_left (fun graph v -> G.add_vertex graph v) G.empty vertices in + let g = List.fold_left (fun graph (v1, v2) -> G.add_edge graph v1 v2) g edges in + let cliques = BK.maximalcliques g in + (* The cliques of this graph should be: [2, 3], [3, 4], [1, 2, 5], [4, 5], [4, 6], [7] *) + assert (List.length cliques == 6); + assert (List.exists (fun cl -> List.length cl == 2 && List.mem 2 cl && List.mem 3 cl) cliques); + assert (List.exists (fun cl -> List.length cl == 2 && List.mem 3 cl && List.mem 4 cl) cliques); + assert (List.exists (fun cl -> List.length cl == 3 && List.mem 1 cl && List.mem 2 cl && List.mem 5 cl) cliques); + assert (List.exists (fun cl -> List.length cl == 2 && List.mem 4 cl && List.mem 5 cl) cliques); + assert (List.exists (fun cl -> List.length cl == 2 && List.mem 4 cl && List.mem 6 cl) cliques); + assert (List.exists (fun cl -> List.length cl == 1 && List.mem 7 cl) cliques) +end + +module Test_reduction = struct + + open Graph + + module G = Imperative.Digraph.Concrete(struct + type t = int + let compare = compare + let hash = Hashtbl.hash + let equal = (=) end) + open G + + module R = Rand.I(G) + module O = Oper.I(G) + + 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 + + let check_same_graph g1 g2 = + check_included g1 g2; + check_included g2 g1 + + let test v e = + let g = R.graph ~loops:true ~v ~e () in + let t = O.transitive_closure g in + check_included g t; + let r = O.transitive_reduction g in + check_included r g; + check_same_graph (O.transitive_closure r) t + + let () = + for v = 1 to 10 do + for e = 0 to v * (v-1) / 2 do + test v e + done + done + + (* issue #91 *) + let () = + let g = create () in + for v = 1 to 5 do add_vertex g v done; + add_edge g 1 2; add_edge g 2 3; add_edge g 3 4; add_edge g 4 5; + add_edge g 2 5; + let r = O.transitive_reduction g in + check_included r g; + assert (nb_edges r = 4); + assert (not (mem_edge r 2 5)); + () + +end + +let () = Format.printf "check: all tests succeeded@." + (* Local Variables: diff --git a/tests/test.ml b/tests/test.ml index 7cde8225..7ed29121 100644 --- a/tests/test.ml +++ b/tests/test.ml @@ -67,4 +67,3 @@ let n, f = Comp.scc g let () = G.iter_edges (fun u v -> printf "%d -> %d@." u v) g let () = printf "%d components@." n let () = G.iter_vertex (fun v -> printf " %d -> %d@." v (f v)) g - diff --git a/tests/test_clique.ml b/tests/test_clique.ml deleted file mode 100644 index 651527d3..00000000 --- a/tests/test_clique.ml +++ /dev/null @@ -1,29 +0,0 @@ -(* Test file for Brom-Kerbosch *) - -open Graph - -module G = Persistent.Graph.Concrete (struct - type t = int - let compare = compare - let hash = Hashtbl.hash - let equal = (=) -end) - -module BK = Clique.Bron_Kerbosch(G) - -let () = - let vertices = [1;2;3;4;5;6;7] in - let edges = [(1,2);(1,5);(2,5);(2,3);(4,5);(3,4);(4,6)] in - let g = List.fold_left (fun graph v -> G.add_vertex graph v) G.empty vertices in - let g = List.fold_left (fun graph (v1, v2) -> G.add_edge graph v1 v2) g edges in - let cliques = BK.maximalcliques g in - (* The cliques of this graph should be: [2, 3], [3, 4], [1, 2, 5], [4, 5], [4, 6], [7] *) - assert (List.length cliques == 6); - assert (List.exists (fun cl -> List.length cl == 2 && List.mem 2 cl && List.mem 3 cl) cliques); - assert (List.exists (fun cl -> List.length cl == 2 && List.mem 3 cl && List.mem 4 cl) cliques); - assert (List.exists (fun cl -> List.length cl == 3 && List.mem 1 cl && List.mem 2 cl && List.mem 5 cl) cliques); - assert (List.exists (fun cl -> List.length cl == 2 && List.mem 4 cl && List.mem 5 cl) cliques); - assert (List.exists (fun cl -> List.length cl == 2 && List.mem 4 cl && List.mem 6 cl) cliques); - assert (List.exists (fun cl -> List.length cl == 1 && List.mem 7 cl) cliques); -;; - diff --git a/tests/test_topsort.ml b/tests/test_topsort.ml index 6c71d0c0..7f24e473 100644 --- a/tests/test_topsort.ml +++ b/tests/test_topsort.ml @@ -17,13 +17,13 @@ let test ?(check=true) iter n edges = iter (fun v -> incr i; num.(V.label v) <- !i) g; let r = Array.init n (fun i -> i) in Array.sort (fun i j -> num.(i) - num.(j)) r; - if check then for v = 0 to n-1 do printf "%d " r.(v) done; printf "@."; + (* if check then for v = 0 to n-1 do printf "%d " r.(v) done; printf "@."; *) (* check *) let path = PathCheck.check_path (PathCheck.create g) in let check_edge (x,y) = let vx = v.(x) and vy = v.(y) in - printf "x=%d y=%d num(x)=%d num(y)=%d@." x y num.(x) num.(y); - printf "x-->y=%b y-->x=%b@." (path vx vy) (path vy vx); + (* printf "x=%d y=%d num(x)=%d num(y)=%d@." x y num.(x) num.(y); + * printf "x-->y=%b y-->x=%b@." (path vx vy) (path vy vx); *) assert (num.(x) > 0 && num.(y) > 0); assert (num.(x) >= num.(y) || path vx vy || not (path vy vx)) in if check then @@ -58,7 +58,7 @@ let tests iter = test 7 [0,1; 1,0; 1,2; 2,3; 3,2; 3,4; 4,5; 5,6; 6,4]; (* 3 cycles with 2 cycles in a cycle *) test 7 [0,1; 1,0; 1,2; 2,3; 3,2; 3,4; 4,5; 5,6; 6,4; 5,2]; - printf "All tests succeeded.@." + printf "test topsort: all tests succeeded.@." let () = tests Topological.iter (* let () = tests Topological.iter_stable *)