ensure that map_vertex applies the function only once per vertex

fixes backtracking#110

CHANGES.md

@@ -1,4 +1,6 @@
 
+  - #110: ensure that map_vertex applies the function only once per vertex
+
 # 2.0.0 (October 2, 2020)
 
   - port to dune and opam 2.0

src/blocks.ml

@@ -235,8 +235,10 @@ module Unlabeled(V: COMPARABLE)(HM: HM with type key = V.t) = struct
   let succ g v = S.elements (HM.find_and_raise v g "[ocamlgraph] succ")
   let succ_e g v = fold_succ_e (fun e l -> e :: l) g v []
 
-  let map_vertex f =
-    HM.map (fun v s -> f v, S.fold (fun v s -> S.add (f v) s) s S.empty)
+  let map_vertex f g =
+    let module MV = Util.Memo(V) in
+    let f = MV.memo f in
+    HM.map (fun v s -> f v, S.fold (fun v s -> S.add (f v) s) s S.empty) g
 
   module I = struct
     type t = S.t HM.t
@@ -348,9 +350,11 @@ struct
   let succ g v = fold_succ (fun w l -> w :: l) g v []
   let succ_e g v = fold_succ_e (fun e l -> e :: l) g v []
 
-  let map_vertex f =
+  let map_vertex f g =
+    let module MV = Util.Memo(V) in
+    let f = MV.memo f in
     HM.map
-      (fun v s -> f v, S.fold (fun (v, l) s -> S.add (f v, l) s) s S.empty)
+      (fun v s -> f v, S.fold (fun (v, l) s -> S.add (f v, l) s) s S.empty) g
 
   module I = struct
     type t = S.t HM.t
@@ -561,12 +565,15 @@ module BidirectionalUnlabeled(V:COMPARABLE)(HM:HM with type key = V.t) = struct
   let succ g v = S.elements (snd (HM.find_and_raise v g "[ocamlgraph] succ"))
   let succ_e g v = fold_succ_e (fun e l -> e :: l) g v []
 
-  let map_vertex f =
+  let map_vertex f g =
+    let module MV = Util.Memo(V) in
+    let f = MV.memo f in
     HM.map
       (fun v (s1,s2) ->
          f v,
          (S.fold (fun v s -> S.add (f v) s) s1 S.empty,
           S.fold (fun v s -> S.add (f v) s) s2 S.empty))
+      g
 
   module I = struct
     (* we keep sets for both incoming and outgoing edges *)
@@ -703,12 +710,15 @@ struct
   let succ g v = fold_succ (fun w l -> w :: l) g v []
   let succ_e g v = fold_succ_e (fun e l -> e :: l) g v []
 
-  let map_vertex f =
+  let map_vertex f g =
+    let module MV = Util.Memo(V) in
+    let f = MV.memo f in
     HM.map
       (fun v (s1,s2) ->
          f v,
          (S.fold (fun (v, l) s -> S.add (f v, l) s) s1 S.empty,
           S.fold (fun (v, l) s -> S.add (f v, l) s) s2 S.empty))
+    g
 
   module I = struct
     type t = (S.t * S.t) HM.t

src/imperative.ml

@@ -477,15 +477,13 @@ module Matrix = struct
     (* map iterator on vertex *)
     let map_vertex f g =
       let n = nb_vertex g in
+      let f i = (* ensures f is applied exactly once for each vertex *)
+        let fi = f i in
+        if fi < 0 || fi >= n then invalid_arg "[ocamlgraph] map_vertex";
+        fi in
+      let v = Array.init n f in
       let g' = make n in
-      iter_edges
-        (fun i j ->
-           let fi = f i in
-           let fj = f j in
-           if fi < 0 || fi >= n || fj < 0 || fj >= n then
-             invalid_arg "[ocamlgraph] map_vertex";
-           Bitv.unsafe_set g'.(fi) fj true)
-        g;
+      iter_edges (fun i j -> Bitv.unsafe_set g'.(v.(i)) v.(j) true) g;
       g'
 
     (* labeled edges going from/to a vertex *)

src/util.ml

@@ -48,3 +48,9 @@ module DataV(L : sig type t end)(V : Sig.COMPARABLE) = struct
   let set_data (y, _) = (:=) y
 end
 
+module Memo(X: HASHABLE) = struct
+  module H = Hashtbl.Make(X)
+  let memo ?(size=128) f =
+    let h = H.create size in
+    fun x -> try H.find h x with Not_found -> let y = f x in H.add h x y; y
+end

src/util.mli

@@ -45,3 +45,6 @@ module DataV(L : sig type t end)(V : Sig.COMPARABLE) : sig
   val set_data : t -> data -> unit
 end
 
+module Memo(X: HASHABLE) : sig
+  val memo: ?size:int -> (X.t -> 'a) -> X.t -> 'a
+end

tests/dune

@@ -8,6 +8,11 @@
  (libraries graph)
  (modules test_topsort))
 
+(test
+ (name test_map_vertex)
+ (libraries graph)
+ (modules test_map_vertex))
+
 ;; Rules for the Bellman-Ford tests
 
 (rule

tests/test_map_vertex.ml

@@ -0,0 +1,80 @@
+
+(* Check that map_vertex applies the function exactly once per vertex *)
+
+open Graph
+
+let () = Random.init 1597
+
+module TestB(B: Builder.S with type G.V.label = int) = struct
+  let test n =
+    let v = Array.init n B.G.V.create in
+    let rec make g i =
+      if i = n then g else make (B.add_vertex g v.(i)) (i + 1) in
+    let g = ref (make (B.empty ()) 0) in
+    for i = 0 to n - 1 do
+      for j = 0 to n - 1 do
+        if Random.bool () then g := B.add_edge !g v.(i) v.(j)
+      done
+    done;
+    let counter = ref 0 in
+    let f x = incr counter; x in
+    let g' = B.G.map_vertex f !g in
+    assert (!counter = n);
+    assert (B.G.nb_vertex g' = n)
+
+  let () =
+    for n = 0 to 10 do test n done
+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
+
+include TestI(Pack.Digraph)
+include TestI(Pack.Graph)
+
+(* imperative, directed *)
+include TestI(Imperative.Digraph.Concrete(Int))
+include TestI(Imperative.Digraph.Abstract(Int))
+include TestI(Imperative.Digraph.ConcreteBidirectional(Int))
+include TestI(Imperative.Digraph.ConcreteLabeled(Int)(Int))
+include TestI(Imperative.Digraph.AbstractLabeled(Int)(Int))
+include TestI(Imperative.Digraph.ConcreteBidirectionalLabeled(Int)(Int))
+(* imperative, undirected *)
+include TestI(Imperative.Graph.Concrete(Int))
+include TestI(Imperative.Graph.Abstract(Int))
+include TestI(Imperative.Graph.ConcreteLabeled(Int)(Int))
+include TestI(Imperative.Graph.AbstractLabeled(Int)(Int))
+
+module TestM(G: Imperative.Matrix.S) = struct
+  let test n =
+    let g = G.make n in
+    for i = 0 to n - 1 do
+      for j = 0 to n - 1 do
+        if Random.bool () then G.add_edge g i j
+      done
+    done;
+    let counter = ref 0 in
+    let f x = incr counter; x in
+    let g' = G.map_vertex f g in
+    assert (!counter = n);
+    assert (G.nb_vertex g' = n)
+
+  let () =
+    for n = 0 to 10 do test n done
+end
+include TestM(Imperative.Matrix.Digraph)
+include TestM(Imperative.Matrix.Graph)
+
+(* persistent, directed *)
+include TestP(Persistent.Digraph.Concrete(Int))
+include TestP(Persistent.Digraph.Abstract(Int))
+include TestP(Persistent.Digraph.ConcreteBidirectional(Int))
+include TestP(Persistent.Digraph.ConcreteLabeled(Int)(Int))
+include TestP(Persistent.Digraph.AbstractLabeled(Int)(Int))
+include TestP(Persistent.Digraph.ConcreteBidirectionalLabeled(Int)(Int))
+(* persistent, undirected *)
+include TestP(Persistent.Graph.Concrete(Int))
+include TestP(Persistent.Graph.Abstract(Int))
+include TestP(Persistent.Graph.ConcreteLabeled(Int)(Int))
+include TestP(Persistent.Graph.AbstractLabeled(Int)(Int))