[dgraph] fixed method get_edge_layout of class abstract_model

CHANGES

@@ -1,6 +1,8 @@
 
 * marks some incompatible change
 
+ * fixed method get_edge_layout of class abstract_model of DGraphModel.Make. The
+   bug could have occured when there are several edges between two vertices.
  o [Traverse/Pack] added Dfs.fold and Dfs.fold_component (tail-recursive)
    (contributed by Guillaume Chelfi)
  * fixed implementation of Golberg-Tarjan maximal flow algorithm

dgraph/dGraphModel.ml

@@ -61,12 +61,16 @@ end
 
 (* BUILDING A MODEL WITH AN OCAML GRAPH *)
 
-module Make(G : Graphviz.GraphWithDotAttrs) = struct
+module Make(G : Graphviz.GraphWithDotAttrs)
+ = struct
+
+   exception Multiple_layouts of (G.E.t * edge_layout) list
 
   type cluster = string
   module X = XDot.Make(G)
 
-  class model layout g : [G.vertex, G.edge, cluster] abstract_model = object
+  class model layout g : [G.vertex, G.edge, cluster] abstract_model =
+  object (self)
 
     (* Iterators *)
     method iter_edges f = G.iter_edges f g
@@ -96,8 +100,28 @@ module Make(G : Graphviz.GraphWithDotAttrs) = struct
       with Not_found -> assert false
 
     method get_edge_layout e =
-      try X.HE.find layout.X.edge_layouts e
-      with Not_found -> assert false
+      try X.HE.find e layout.X.edge_layouts
+      with Not_found ->
+        (* if there are several edges from a vertex [v1] to a vertex [v2], they
+           can share the same layout. In that case, one these edges is
+           unfortunately not in the layout table because of key sharing. Try to
+           recover it when possible by creating a list of all possible layouts
+           for the given edge. If there is only one, easy win, otherwise return
+           them all in an exception and let the caller decide what to do *)
+        let layouts = ref [] in
+        self#iter_succ_e
+          (fun e' ->
+            if G.V.equal (self#dst e) (self#dst e') then
+              try
+                let layout = X.HE.find e' layout.X.edge_layouts in
+                if not (List.exists (fun (_, l) -> layout = l) !layouts) then
+                  layouts := (e', layout) :: !layouts
+              with Not_found -> ())
+          (self#src e);
+        match !layouts with
+        | [] -> assert false
+        | [ _, x ] -> x
+        | _ :: _ :: _ -> raise (Multiple_layouts !layouts)
 
     method get_cluster_layout c =
       try Hashtbl.find layout.X.cluster_layouts c
@@ -112,9 +136,8 @@ module Make(G : Graphviz.GraphWithDotAttrs) = struct
     DumpDot.output_graph out g;
     close_out out;
     (* Get layout from dot file *)
-    let layout = 
-      try
-        X.layout_of_dot ~cmd ~dot_file g 
+    let layout =
+      try X.layout_of_dot ~cmd ~dot_file g
       with X.DotError err -> raise (DotError err)
     in
     let model = new model layout g in

dgraph/dGraphModel.mli

@@ -55,6 +55,9 @@ class type ['vertex, 'edge, 'cluster] abstract_model = object
   (** Dot layout *)
   method bounding_box : bounding_box
   method get_edge_layout : 'edge -> edge_layout
+  (** @raise Multiple_layouts when there are several possible layouts for the
+      given edge *)
+
   method get_vertex_layout : 'vertex -> node_layout
   method get_cluster_layout : 'cluster -> cluster_layout
 end
@@ -63,6 +66,7 @@ end
 module Make(G : Graph.Graphviz.GraphWithDotAttrs) : sig
 
   type cluster = string
+  exception Multiple_layouts of (G.E.t * edge_layout) list
 
   class model:
     XDot.Make(G).graph_layout -> G.t -> [G.V.t, G.E.t, cluster] abstract_model

dgraph/dGraphTreeLayout.ml

@@ -472,7 +472,9 @@ struct
     mutable style : [ `Solid | `Dashed | `Dotted | `Bold | `Invis ] list
   }
 
-  let rec attributes_list_to_eattributes eattrs : edge list -> _ = function
+  let rec attributes_list_to_eattributes (eattrs:eattributes)
+      : edge list -> _
+    = function
     |[] -> ()
     | `Color c :: q ->
       eattrs.color <-
@@ -618,19 +620,19 @@ struct
          HV.add vertex_layouts v n_layout)
       tree;
 
-    let edge_layouts = HE.create 97 in
+    let edge_layouts = ref HE.empty in
     Tree.iter_edges_e
       (fun e ->
          let e_layout = edge_to_edge_layout tree e geometry_info in
-         HE.add edge_layouts e e_layout)
+         edge_layouts := HE.add e e_layout !edge_layouts)
       tree;
 
     let cluster_layouts = Hashtbl.create 7
     (* [JS 2010/09/09] does not work *)
     (*  build_cluster_layouts tree geometry_info*)
     in
     { vertex_layouts = vertex_layouts;
-      edge_layouts = edge_layouts;
+      edge_layouts = !edge_layouts;
       cluster_layouts = cluster_layouts;
       bbox =
         let ((_,_), (_,_) as bb) =
@@ -828,7 +830,7 @@ struct
          let v_layout = parse_vertex_layout tree v old_layout geometry_info in
          HV.add vertex_layouts v v_layout)
       tree;
-    let edge_layouts = HE.create 97 in
+    let edge_layouts = ref HE.empty in
     Tree.iter_edges_e
       (fun e ->
          let src = Tree.V.label (Tree.E.src e) in
@@ -844,12 +846,12 @@ struct
                e_tldraw = [] }
          in
          let e_layout = parse_edge_layout tree e old_layout geometry_info in
-         HE.add edge_layouts e e_layout)
+         edge_layouts := HE.add e e_layout !edge_layouts)
       tree;
     let cluster_layouts = Hashtbl.create 7 in
     let root_pos = get_position root geometry_info in
     { vertex_layouts = vertex_layouts;
-      edge_layouts = edge_layouts;
+      edge_layouts = !edge_layouts;
       cluster_layouts = cluster_layouts;
       bbox =
         let ((_,_), (_,_) as bb) =

dgraph/dGraphTreeModel.ml

@@ -39,9 +39,10 @@ module type S = sig
   end
 
   type cluster = string
+  type graph_layout
 
   class tree_model :
-    XDot.Make(Tree).graph_layout ->
+    graph_layout ->
     TreeManipulation.t ->
     [Tree.V.t, Tree.E.t, cluster] DGraphModel.abstract_model
 
@@ -61,6 +62,7 @@ struct
   type cluster = string
 
   module X = XDot.Make(T)
+  type graph_layout = X.graph_layout
 
   class tree_model layout tree
     : [ T.V.t, T.E.t, cluster ] DGraphModel.abstract_model
@@ -134,7 +136,7 @@ struct
         with Not_found -> assert false
 
       method get_edge_layout e =
-        try X.HE.find layout.X.edge_layouts e
+        try X.HE.find e layout.X.edge_layouts
         with Not_found -> assert false
 
       method get_cluster_layout c =

dgraph/dGraphTreeModel.mli

@@ -37,9 +37,10 @@ module type S = sig
   end
 
   type cluster = string
+  type graph_layout
 
   class tree_model :
-    XDot.Make(Tree).graph_layout ->
+    graph_layout ->
     TreeManipulation.t ->
     [ Tree.V.t, Tree.E.t, cluster ] DGraphModel.abstract_model
 

dgraph/xDot.ml

@@ -200,12 +200,13 @@ let read_bounding_box str =
 module Make(G : Graph.Graphviz.GraphWithDotAttrs) = struct
 
   module HV = Hashtbl.Make(G.V)
+
+  (* cannot use an hashtable because no hash function for edges *)
   module HE =
-    Hashtbl.Make
+    Map.Make
       (struct
         type t = G.E.t
-        let equal x y = G.E.compare x y = 0
-        let hash = Hashtbl.hash
+        let compare = G.E.compare
       end)
 
   module HT =
@@ -274,7 +275,7 @@ module Make(G : Graph.Graphviz.GraphWithDotAttrs) = struct
     let vertices_comment_to_edge = HT.create 97 in
 
     let vertex_layouts = HV.create 97 in
-    let edge_layouts = HE.create 97 in
+    let edge_layouts = ref HE.empty in
     let cluster_layouts = Hashtbl.create 97 in
 
     G.iter_vertex
@@ -319,7 +320,7 @@ module Make(G : Graph.Graphviz.GraphWithDotAttrs) = struct
           let v' = find_vertex id' in
           let comment = get_dot_comment al in
           let e = find_edge v v' comment in
-          HE.add edge_layouts e (read_edge_layout al)
+          edge_layouts := HE.add e (read_edge_layout al) !edge_layouts
         | Subgraph (SubgraphDef (Some id, stmts)) ->
           let cluster = get_dot_string id in
           List.iter (collect_layouts (Some cluster)) stmts
@@ -342,7 +343,7 @@ module Make(G : Graph.Graphviz.GraphWithDotAttrs) = struct
     let bbox = parse_bounding_box dot_ast.stmts in
     (* let bgcolor = parse_bgcolor dot_ast.stmts in*)
     { vertex_layouts  = v_layouts;
-      edge_layouts    = e_layouts;
+      edge_layouts    = !e_layouts;
       cluster_layouts = c_layouts;
       bbox = bbox }
 

dgraph/xDot.mli

@@ -108,7 +108,7 @@ exception ParseError of string
 module Make(G : Graph.Graphviz.GraphWithDotAttrs) : sig
 
   module HV: Hashtbl.S with type key = G.V.t
-  module HE: Hashtbl.S with type key = G.E.t
+  module HE: Map.S with type key = G.E.t
 
   (** Main layout type *)
   type graph_layout =