Merge branch 'backtracking:master' into master

CHANGES.md

@@ -1,4 +1,9 @@
 
+# 2.1.0 (August 30, 2023)
+
+  - :exclamation: OCamlGraph now requires OCaml >= 4.08
+  - :exclamation: [Traverse]: fixed [Dfs.fold] and [Dfs.fold_component],
+    which were not implementing a proper DFS
   - [Classic]: new functions [cycle] and [grid]
   - [Eulerian]: Eulerian paths (new module)
   - [Components]: strong articulation points (see functors [Connectivity]

ocamlgraph.opam

@@ -1,7 +1,7 @@
 opam-version: "2.0"
 synopsis: "A generic graph library for OCaml"
 description: "Provides both graph data structures and graph algorithms"
-maintainer: ["filliatr@lri.fr"]
+maintainer: ["jean-christophe.filliatre@cnrs.fr"]
 authors: ["Sylvain Conchon" "Jean-Christophe Filliâtre" "Julien Signoles"]
 license: "LGPL-2.1-only"
 tags: [
@@ -18,13 +18,13 @@ homepage: "https://github.com/backtracking/ocamlgraph/"
 doc: "https://backtracking.github.io/ocamlgraph"
 bug-reports: "https://github.com/backtracking/ocamlgraph/issues/new"
 depends: [
-  "ocaml" {>= "4.03.0"}
+  "ocaml" {>= "4.08.0"}
   "stdlib-shims"
   "dune" {>= "2.0"}
   "graphics" {with-test}
 ]
 build: [
-  ["dune" "subst"] {pinned}
+  ["dune" "subst"] {dev}
   [
     "dune"
     "build"

ocamlgraph_gtk.opam

@@ -1,7 +1,7 @@
 opam-version: "2.0"
 synopsis: "Displaying graphs using OCamlGraph and GTK"
 description: "Displaying graphs using OCamlGraph and GTK"
-maintainer: ["filliatr@lri.fr"]
+maintainer: ["jean-christophe.filliatre@cnrs.fr"]
 authors: ["Sylvain Conchon" "Jean-Christophe Filliâtre" "Julien Signoles"]
 license: "LGPL-2.1-only"
 tags: [
@@ -18,7 +18,7 @@ homepage: "https://github.com/backtracking/ocamlgraph/"
 doc: "https://backtracking.github.io/ocamlgraph"
 bug-reports: "https://github.com/backtracking/ocamlgraph/issues/new"
 depends: [
-  "ocaml" {>= "4.03.0"}
+  "ocaml" {>= "4.08.0"}
   "stdlib-shims"
   "lablgtk"
   "conf-gnomecanvas"
@@ -27,7 +27,7 @@ depends: [
   "graphics" {with-test}
 ]
 build: [
-  ["dune" "subst"] {pinned}
+  ["dune" "subst"] {dev}
   [
     "dune"
     "build"

src/cycles.ml

@@ -14,7 +14,7 @@ struct
 
   exception Stuck of G.vertex list
 
-  module IM = Map.Make (Int)
+  module IM = Map.Make (struct type t = int let compare = Stdlib.compare end)
   module VM = Map.Make (G.V)
   module VS = Set.Make (G.V)
 
@@ -187,6 +187,7 @@ struct
      of an obligatory arc. Use the "unbalanced" heuristic impllemented in
      [takemax] to discriminate between competing possibilities. If a vertex
      is found, remove it from the returned delta bins. *)
+(*
   let max_from_deltas g ({ delta_bins; _ } as st) =
     let rec f = function
       | Seq.Nil -> None
@@ -196,6 +197,18 @@ struct
            | Some (_, v) -> Some (v, remove_from_bin v st))
     in
     f (IM.to_rev_seq delta_bins ())
+*)
+  let max_from_deltas g ({ delta_bins; _ } as st) =
+    let rec f im =
+      if IM.is_empty im then
+        None
+      else
+        let k, dbin = IM.max_binding im in
+        (match VS.fold (takemax g) dbin None with
+           | None -> f (IM.remove k im)
+           | Some (_, v) -> Some (v, remove_from_bin v st))
+    in
+    f delta_bins
 
   (* Include any leftward arcs due to the two-cycles that were removed by
      preprocessing. *)

src/traverse.ml

@@ -31,22 +31,23 @@ end
 module Dfs(G : G) = struct
   module H = Hashtbl.Make(G.V)
 
-  let fold f i g =
+  let fold f acc g =
     let h = H.create 97 in
     let s = Stack.create () in
-    let push v =
-      if not (H.mem h v) then begin H.add h v (); Stack.push v s end
-    in
     let rec loop acc =
       if not (Stack.is_empty s) then
         let v = Stack.pop s in
-        let ns = f v acc in
-        G.iter_succ push g v;
-        loop ns
+        if not (H.mem h v) then begin
+          H.add h v ();
+          let acc = f v acc in
+          G.iter_succ (fun w -> Stack.push w s) g v;
+          loop acc
+        end else
+          loop acc
       else
         acc
     in
-    G.fold_vertex (fun v s -> push v; loop s) g i
+    G.fold_vertex (fun v acc -> Stack.push v s; loop acc) g acc
 
   let iter ?(pre=fun _ -> ()) ?(post=fun _ -> ()) g =
     let h = H.create 97 in
@@ -62,24 +63,24 @@ module Dfs(G : G) = struct
 
   let postfix post g = iter ~post g
 
-  let fold_component f i g v0 =
+  let fold_component f acc g v0 =
     let h = H.create 97 in
     let s = Stack.create () in
-    (* invariant: [h] contains exactly the vertices which have been pushed *)
-    let push v =
-      if not (H.mem h v) then begin H.add h v (); Stack.push v s end
-    in
-    push v0;
+    Stack.push v0 s;
     let rec loop acc =
       if not (Stack.is_empty s) then
         let v = Stack.pop s in
-        let ns = f v acc in
-        G.iter_succ push g v;
-        loop ns
+        if not (H.mem h v) then begin
+          H.add h v ();
+          let acc = f v acc in
+          G.iter_succ (fun w -> Stack.push w s) g v;
+          loop acc
+        end else
+          loop acc
       else
         acc
     in
-    loop i
+    loop acc
 
   let iter_component ?(pre=fun _ -> ()) ?(post=fun _ -> ()) g v =
     let h = H.create 97 in

tests/dune

@@ -3,6 +3,11 @@
  (libraries graph)
  (modules check))
 
+(test
+ (name test_dfs)
+ (libraries graph)
+ (modules test_dfs))
+
 (test
  (name test_topsort)
  (libraries graph)

tests/test_components.expected

@@ -1,11 +1,9 @@
-7 components
+4 components
 0 -> 0
 1 -> 1
-2 -> 2
-3 -> 3
-4 -> 1
-5 -> 1
-6 -> 4
-7 -> 1
-8 -> 5
-9 -> 6
+2 -> 0
+3 -> 2
+4 -> 2
+5 -> 3
+6 -> 2
+7 -> 0

tests/test_components.ml

@@ -22,16 +22,20 @@ module C = Components.Undirected(Pack.Graph)
 
 open Pack.Graph
 
+(*         0 -- 2 -- 7   1   3 -- 4   5
+                             \  /
+                               6
+
+component:      0        1     2      3
+*)
+
 let () =
-  Random.init 42;
-  let g = Rand.graph ~v:10 ~e:3 () in
+  let g = create () in
+  let v = Array.init 8 V.create in
+  Array.iter (add_vertex g) v;
+  let add i j = add_edge g v.(i) v.(j) in
+  add 0 2; add 7 2; add 3 4; add 4 6; add 3 6;
   let n, f = C.components g in
   printf "%d components@." n;
   iter_vertex (fun v -> printf "%d -> %d@." (V.label v) (f v)) g
 
-
-(*
-Local Variables:
-compile-command: "ocaml -I .. graph.cma test_components.ml"
-End:
-*)

tests/test_dfs.ml

@@ -0,0 +1,73 @@
+
+(* Stack-based DFS is tricky to get right. See
+   https://11011110.github.io/blog/2013/12/17/stack-based-graph-traversal.html
+
+   On this graph,
+
+         0
+       /   \
+      /     \
+     v       v
+     1---2---3    (All edges are undirected,
+     |\     /|     apart from 0->1 0->3 1->5 and 3->6.)
+     | \   / |
+     |   4   |
+     |  / \  |
+     v /   \ v
+     5       6
+
+  an incorrect stack-based DFS starting from 0 would first mark 1 and 3,
+  and then would not go as deep as possible in the traversal.
+
+  In the following, we check that, whenever 2 and 4 are visited,
+  then necessarily both 1 and 3 are already visited.
+*)
+
+open Format
+open Graph
+open Pack.Digraph
+
+let debug = false
+
+let g = create ()
+let v = Array.init 7 V.create
+let () = Array.iter (add_vertex g) v
+let adde x y = add_edge g v.(x) v.(y)
+let addu x y = adde x y; adde y x
+let () = adde 0 1; adde 0 3
+let () = addu 1 2; addu 2 3
+let () = adde 1 5; adde 3 6
+let () = addu 1 4; addu 4 3; addu 5 4; addu 4 6
+
+let () = assert (Dfs.has_cycle g)
+
+let marked = Array.make 7 false
+let reset () = Array.fill marked 0 7 false
+let mark v =
+  let i = V.label v in
+  marked.(i) <- true;
+  if marked.(2) && marked.(4) then assert (marked.(1) && marked.(3))
+
+let pre  v = if debug then printf "pre  %d@." (V.label v); mark v
+let post v = if debug then printf "post %d@." (V.label v)
+let f v () = if debug then printf "fold %d@." (V.label v); mark v
+
+let () = reset (); Dfs.iter ~pre ~post g
+let () = reset (); Dfs.prefix pre g
+let () = reset (); Dfs.postfix post g
+let () = reset (); Dfs.iter_component ~pre ~post g v.(0)
+let () = reset (); Dfs.prefix_component pre g v.(0)
+let () = reset (); Dfs.postfix_component post g v.(0)
+let () = reset (); Dfs.fold f () g
+let () = reset (); Dfs.fold_component f () g v.(0)
+
+module D = Traverse.Dfs(Pack.Digraph)
+
+let rec visit it =
+  let v = D.get it in
+  mark v;
+  visit (D.step it)
+
+let () = try visit (D.start g) with Exit -> ()
+
+let () = printf "All tests succeeded.@."

tests/test_map_vertex.ml

@@ -28,7 +28,10 @@ end
 module TestI(G: Sig.I with type V.label = int) = TestB(Builder.I(G))
 module TestP(G: Sig.P with type V.label = int) = TestB(Builder.P(G))
 
-module Int = struct include Int let hash x = x let default = 42 end
+module Int = struct
+  type t = int let compare = Stdlib.compare let equal = (=)
+  let hash x = x let default = 42
+end
 
 include TestI(Pack.Digraph)
 include TestI(Pack.Graph)