diff --git a/CHANGES b/CHANGES index 3acbe362..6a326c55 100644 --- a/CHANGES +++ b/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 diff --git a/dgraph/dGraphModel.ml b/dgraph/dGraphModel.ml index 006355b5..f315f571 100644 --- a/dgraph/dGraphModel.ml +++ b/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 diff --git a/dgraph/dGraphModel.mli b/dgraph/dGraphModel.mli index c422ad77..7df58002 100644 --- a/dgraph/dGraphModel.mli +++ b/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 diff --git a/dgraph/dGraphTreeLayout.ml b/dgraph/dGraphTreeLayout.ml index 7ec75315..4efb219c 100644 --- a/dgraph/dGraphTreeLayout.ml +++ b/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,11 +620,11 @@ 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 @@ -630,7 +632,7 @@ struct (* 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) = diff --git a/dgraph/dGraphTreeModel.ml b/dgraph/dGraphTreeModel.ml index 2b5ef285..b235a925 100644 --- a/dgraph/dGraphTreeModel.ml +++ b/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 = diff --git a/dgraph/dGraphTreeModel.mli b/dgraph/dGraphTreeModel.mli index da9d9d7b..e8a6edff 100644 --- a/dgraph/dGraphTreeModel.mli +++ b/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 diff --git a/dgraph/xDot.ml b/dgraph/xDot.ml index c00dcc99..f5dd5271 100644 --- a/dgraph/xDot.ml +++ b/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 } diff --git a/dgraph/xDot.mli b/dgraph/xDot.mli index 67e3cf19..c225d8f0 100644 --- a/dgraph/xDot.mli +++ b/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 =