(*********************************************************************************) |
(* Odot *)
(* *)
(* Copyright (C) 2005 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. *)
(* *)
(* This program is free software; you can redistribute it and/or modify *)
(* it under the terms of the GNU General Public License as published *)
(* by the Free Software Foundation; either version 2.1 of the License, or *)
(* any later version. *)
(* *)
(* This program is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
(* GNU Lesser General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU General Public License *)
(* along with this program; if not, write to the Free Software *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *)
(* 02111-1307 USA *)
(* *)
(* Contact: Maxence.Guesdon@inria.fr *)
(*********************************************************************************) |
(* $Id: odot_view.ml 662 2008-09-09 07:25:32Z zoggy $ *)
(** A Lablgtk2 box to view dot graphs.*) |
let default_dot_ppi = 72.0
let p_dbg s = ()
(* let p_dbg = prerr_endline *)
type dot_program = Dot | Fdp | Neato | Twopi | Circo
let string_of_dot_program = function
Dot -> "dot"
| Fdp -> "fdp"
| Circo -> "circo"
| Neato -> "neato"
| Twopi -> "twopi"
(*c==v=[String.split_string]=1.0====*)
let split_string s chars =
let len = String.length s in
let rec iter acc pos =
if pos >= len then
match acc with
"" -> []
| _ -> [acc]
else
if List.mem s.[pos] chars then
match acc with
"" -> iter "" (pos + 1)
| _ -> acc :: (iter "" (pos + 1))
else
iter (Printf.sprintf "%s%c" acc s.[pos]) (pos + 1)
in
iter "" 0
(*/c==v=[String.split_string]=1.0====*)
let show image file zoom_file zoom =
let com = Printf.sprintf "convert -resize %d%% %s %s"
zoom
(Filename.quote file)
(Filename.quote zoom_file)
in
match Sys.command com with
0 -> image#set_file zoom_file
| n -> failwith (Printf.sprintf "Exec error %d: %s" n com)
let get_graph_bounding_box stmt_list =
let rec iter = function
[] -> raise Not_found
| (Odot.Stmt_attr (Odot.Attr_graph attr_list)) :: q ->
begin
match Odot.attr_value (Odot.Simple_id "bb") attr_list with
Some (Odot.Simple_id v)
| Some (Odot.Double_quoted_id v) ->
begin
match split_string v [','] with
[x1;y1;x2;y2] ->
(
let (a,b,c,d) =
try (int_of_string x1, int_of_string y1,
int_of_string x2, int_of_string y2)
with | _ -> raise Not_found
in
match a,b,c,d with
0, _, _, 0 -> (0,0,c,b)
| _ as x -> x
)
| _ -> raise Not_found
end
| _ -> iter q
end
| _ :: q -> iter q
in
iter stmt_list
let analyse_annot_dot_file f =
try
let graph = Odot.parse_file f in
let (_,_,width,height) = get_graph_bounding_box graph.Odot.stmt_list in
p_dbg (Printf.sprintf "width=%d,height=%d" width height);
let rec iter acc = function
[] -> acc
| stmt :: q ->
match stmt with
Odot.Stmt_node (node_id,attr_list) ->
p_dbg "Stmt_node";
begin
try
let w =
match Odot.attr_value (Odot.Simple_id "width") attr_list with
| Some (Odot.Simple_id v)
| Some (Odot.Double_quoted_id v) ->
(try float_of_string v
with _ -> raise Not_found)
| _ -> raise Not_found
in
let h =
match Odot.attr_value (Odot.Simple_id "height") attr_list with
| Some (Odot.Simple_id v)
| Some (Odot.Double_quoted_id v) ->
(try float_of_string v
with _ -> raise Not_found)
| _ -> raise Not_found
in
let (x,y) =
match Odot.attr_value (Odot.Simple_id "pos") attr_list with
| Some (Odot.Simple_id v)
| Some (Odot.Double_quoted_id v) ->
begin
match split_string v [','] with
[x;y] ->
(
try (int_of_string x, int_of_string y)
with | _ -> raise Not_found
)
| _ -> raise Not_found
end
| _ -> raise Not_found
in
let w = w *. default_dot_ppi in
let h = h *. default_dot_ppi in
let x1 = (float x) -. w /. 2.0 in
let y1 = (float y) -. h /. 2.0 in
let x2 = (float x) +. w /. 2.0 in
let y2 = (float y) +. h /. 2.0 in
let s_id = Odot.string_of_node_id node_id in
p_dbg (Printf.sprintf "id %s: x1=%f y1=%f x2=%f y2=%f"
s_id x1 y1 x2 y2);
iter ((x1,y1,x2,y2,s_id)::acc) q
with
Not_found ->
iter acc q
end
| Odot.Stmt_subgraph g ->
iter acc (g.Odot.sub_stmt_list @ q)
| Odot.Stmt_equals _
| Odot.Stmt_edge _
| Odot.Stmt_attr _ -> iter acc q
in
(width, height, iter [] graph.Odot.stmt_list)
with
e ->
p_dbg (Printexc.to_string e);
(1, 1, [])
class virtual box ?(dot_program=Dot) ~tmp_hash () =
let dot_file = Printf.sprintf "%s.dot" tmp_hash in
let annot_dot_file = Printf.sprintf "%s.dot_annot" tmp_hash in
let png_file = Printf.sprintf "%s.png" tmp_hash in
let vbox = GPack.vbox () in
let hbox = GPack.hbox ~spacing:5 ~packing:(vbox#pack ~expand: false) () in
let _ = GMisc.label ~text: "Zoom:" ~packing: (hbox#pack ~padding: 4 ~expand: false) () in
let zooms =
[ 10 ; 20 ; 30 ; 40 ; 50 ; 60 ; 70 ; 80 ; 90 ; 100 ; 120 ]
in
let wcombo = GEdit.combo
~popdown_strings: (List.map (fun s -> Printf.sprintf "%d%%" s) zooms)
~allow_empty:false
~enable_arrow_keys:true
~value_in_list:true
~packing: (hbox#pack ~expand: false)
()
in
let wb_refresh = GButton.button ~label: "Refresh"
~packing: (hbox#pack ~expand: false ~padding: 4) ()
in
let wscroll = GBin.scrolled_window
~vpolicy: `AUTOMATIC
~hpolicy: `AUTOMATIC
~packing: (vbox#pack ~expand: true)
()
in
let evt_box = GBin.event_box ~packing: wscroll#add_with_viewport () in
let image = GMisc.image ~file: png_file ~packing:evt_box#add () in
let _ = image#set_xalign 0.0 in
let _ = image#set_yalign 0.0 in
object(self)
val mutable current_zoom = 100.0
val mutable dot_width = 1
val mutable dot_height = 1
val mutable ids = []
method virtual build_graph : Odot.graph
method virtual refresh_data : unit
method virtual on_button1_press : x: int -> y: int -> string option -> unit
method private zoom_file_of_zoom zoom =
Printf.sprintf "%s_%d%%.png" (Filename.chop_extension png_file) zoom
method box = vbox
method zoom () =
let z =
try Scanf.sscanf wcombo#entry#text "%d%%" (fun a -> Some a)
with _ -> None
in
match z with
None -> ()
| Some 100 ->
current_zoom <- 100.0;
image#set_file png_file
| Some z ->
let f = self#zoom_file_of_zoom z in
if Sys.file_exists f then
image#set_file f
else
show image png_file f z;
current_zoom <- float z
method update_info =
let (w,h,l) = analyse_annot_dot_file annot_dot_file in
dot_width <- w;
dot_height <- h;
ids <- l
method clean_files =
List.iter (fun f -> try Sys.remove f with _ -> ())
[ dot_file ; annot_dot_file ; png_file];
List.iter (fun z -> try Sys.remove (self#zoom_file_of_zoom z) with _ -> ()) zooms;
method refresh () =
self#clean_files;
self#refresh_data ;
let g = self#build_graph in
Odot.print_file dot_file g;
let com = Printf.sprintf
"%s -s%d -y %s > %s && %s -s%d -T png -o %s %s "
(string_of_dot_program dot_program)
(int_of_float default_dot_ppi)
(Filename.quote dot_file)
(Filename.quote annot_dot_file)
(string_of_dot_program dot_program)
(int_of_float default_dot_ppi)
(Filename.quote png_file)
(Filename.quote dot_file)
in
(
match Sys.command com with
0 ->
self#update_info ;
self#zoom ()
| n -> GToolbox.message_box "Error"
(Printf.sprintf "Exec error %d: %s" n com)
);
method private on_button1_press_cb x y =
p_dbg (Printf.sprintf "Button 1 pressed ! x=%d y=%d" x y);
let px = image#pixbuf in
let dc =
{
Gobject.kind = `INT ;
Gobject.proj = (function `INT n -> n | _ -> assert false) ;
Gobject.inj = (fun n -> `INT n);
}
in
let image_width = Gobject.Property.get px
{ Gobject.name = "width" ; Gobject.conv = dc }
in
let image_height = Gobject.Property.get px
{ Gobject.name = "height" ; Gobject.conv = dc }
in
let ratio_x = (float image_width) /. (float dot_width) in
let ratio_y = (float image_height) /. (float dot_height) in
p_dbg
(Printf.sprintf "image width=%d height=%d ratio_x=%f ratio_y=%f"
image_width image_height ratio_x ratio_y);
let id_opt =
p_dbg (Printf.sprintf "looking in %d ids" (List.length ids));
let x = float x in
let y = float y in
try
let (x1,y1,x2,y2,id) = List.find
(fun (x1,y1,x2,y2,id) ->
x1 *. ratio_x <= x && x <= x2 *. ratio_x &&
y1 *. ratio_y <= y && y <= y2 *. ratio_y
)
ids
in
p_dbg (Printf.sprintf
"Id %s clicked pixels: x1=%f x2=%f y1=%f y2=%f ratio_x=%f ratio_y=%f"
id
(x1 *. ratio_x) (x2 *. ratio_x)
(y1 *. ratio_y) (y2 *. ratio_y)
ratio_x ratio_y
);
Some id
with Not_found ->
p_dbg "No id found";
None
in
self#on_button1_press ~x ~y id_opt
method on_button3_press x y =
let entries = List.map
(fun z ->
let t = Printf.sprintf "%d%%" z in
`I (t, fun () -> wcombo#entry#set_text t)
)
zooms
in
GToolbox.popup_menu ~entries ~button: 3 ~time: Int32.zero
initializer
ignore (vbox#connect#destroy (fun () -> self#clean_files));
wcombo#entry#set_editable false;
wcombo#entry#set_text "100%";
ignore (wcombo#entry#connect#changed self#zoom );
ignore (wb_refresh#connect#clicked self#refresh);
ignore
(evt_box#event#connect#button_press ~callback:
(fun evt ->
match GdkEvent.Button.button evt with
1 ->
GdkEvent.get_type evt = `BUTTON_PRESS &&
(
let x = int_of_float (GdkEvent.Button.x evt) in
let y = int_of_float (GdkEvent.Button.y evt) in
self#on_button1_press_cb x y;
true
)
| 3 ->
GdkEvent.get_type evt = `BUTTON_PRESS &&
(
let x = int_of_float (GdkEvent.Button.x evt) in
let y = int_of_float (GdkEvent.Button.y evt) in
self#on_button3_press x y;
true
)
| n -> true
)
);
if not (Sys.file_exists annot_dot_file) then
self#refresh ()
else
(
self#refresh_data;
self#update_info
)
end
(*
module GCan = GnoCanvas;;
type text = {
text_item : GCan.text ;
text_fontsize : int ;
}
type node = {
node_item : GCan.base_item ;
node_id : string ;
node_text : text option;
}
let string_of_id = function
Odot.Simple_id s -> s
| Odot.Double_quoted_id s -> s
| Odot.Html_id s -> s
;;
let attr_value name attr =
try
match Odot.attr_value (Odot.Simple_id name) attr with
None -> raise Not_found
| Some s -> string_of_id s
with Not_found ->
match Odot.attr_value (Odot.Double_quoted_id name) attr with
None -> raise Not_found
| Some s -> string_of_id s
;;
let attr_value_opt name attr =
try Some (attr_value name attr)
with Not_found -> None
;;
let attr_value_def name attr def =
try attr_value name attr
with Not_found -> def
;;
let map_opt f = function None -> None | Some x -> Some (f x);;
type props = {
pr_shape : string ;
pr_fillcolor : string option;
pr_fontsize : int;
}
let default_props = {
pr_shape = "ellipse";
pr_fillcolor = None ;
pr_fontsize = 12;
}
let get_label_position attrs =
let f s =
match split_string s [','] with
[x;y] -> Some (float_of_string x, float_of_string y)
| _ -> None
in
match attr_value_opt "lp" attrs with
None -> None
| Some s -> f s
;;
let node_of_odot_node f_click1 f_click3 group props id attrs =
let id = Odot.string_of_id id in
let w = float_of_string (attr_value "width" attrs) in
let h = float_of_string (attr_value "height" attrs) in
let (x,y) =
match split_string (attr_value "pos" attrs) [','] with
[x;y] ->
(
try (int_of_string x, - (int_of_string y))
with | _ -> raise Not_found
)
| _ -> raise Not_found
in
let w = w *. default_dot_ppi in
let h = h *. default_dot_ppi in
let x1 = (float x) -. w /. 2.0 in
let y1 = (float y) -. h /. 2.0 in
let group = GnoCanvas.group ~x: x1 ~y: y1 group in
let x1 = -. w /. 2. in
let y1 = -. h /. 2. in
let x2 = x1 +. w in
let y2 = y1 +. h in
let fun_of_shape = function
"ellipse" -> GCan.ellipse
| _ -> GCan.rect
in
let item =
let f =
match attr_value_opt "shape" attrs with
Some s -> fun_of_shape s
| None -> fun_of_shape props.pr_shape
in
let fill_color =
match attr_value_opt "color" attrs with
None -> props.pr_fillcolor
| x -> x
in
f ~x1 ~y1 ~x2 ~y2 ?fill_color
~props: [`OUTLINE_COLOR "black"]
group
in
let f_event = function
`BUTTON_PRESS ev ->
begin
prerr_endline "click!";
let x = int_of_float (GdkEvent.Button.x ev) in
let y = int_of_float (GdkEvent.Button.y ev) in
match GdkEvent.Button.button ev with
1 -> f_click1 ~x ~y (Some id)
| 3 -> f_click3 ~x ~y (Some id)
| _ -> ()
end;
true
| _ -> false
in
(* now the text *)
let label =
match attr_value_opt "label" attrs with
Some s -> s
| None -> id
in
let text =
match label with
"" -> None
| text ->
let g =
match get_label_position attrs with
None -> group
| Some (x,y) ->
GCan.group ~x ~y group
in
let item = GnoCanvas.text
~text ~font: "Times-Roman"
~props: [`SIZE_POINTS (float props.pr_fontsize)] g
in
let text = {
text_item = item ;
text_fontsize = props.pr_fontsize ;
}
in
Some text
in
ignore(item#connect#event f_event);
{ node_item = (item :> GCan.base_item);
node_id = id ;
node_text = text ;
}
;;
let props_of_graph_node_attr pr attrs =
let props =
[ "color", (fun p v -> { p with pr_fillcolor = Some v });
"shape", (fun p v -> { p with pr_shape = v }) ;
"fontsize", (fun p v -> { p with pr_fontsize = int_of_string v});
]
in
let f p (name, v) =
try
let f = List.assoc (string_of_id name) props in
match map_opt string_of_id v with
None -> p
| Some v -> f p v
with Not_found -> p
in
List.fold_left f pr attrs
;;
let get_graph_attrs stmt_list =
let f acc = function
Odot.Stmt_attr (Odot.Attr_graph l) -> l @ acc
| _ -> acc
in
List.fold_left f [] stmt_list
;;
let create_subgraph f_click1 f_click3 group props g =
let node =
try
let (x,y,w,h) = get_graph_bounding_box g.Odot.sub_stmt_list in
let attrs = List.map
(fun (s1,s2) -> (Odot.Simple_id s1, Some (Odot.Double_quoted_id s2)))
[
"height", string_of_int h;
"width", string_of_int w;
"pos", Printf.sprintf "%d,%d" x y ;
]
in
let id =
match g.Odot.sub_id with None -> Odot.Simple_id "" | Some id -> id
in
node_of_odot_node f_click1 f_click3 group props id
(attrs @ (get_graph_attrs g.Odot.sub_stmt_list))
with _ ->
let item = GCan.rect ~x1: 0.0 ~y1: 0. ~x2: 0. ~y2: 0. group in
{ node_item = (item :> GCan.base_item) ;
node_id = "";
node_text = None ;
}
in
(node, group)
;;
let edges_of_odot_edges group props points attrs =
[]
;;
class virtual box ?(dot_program=Dot) ~tmp_hash () =
let dot_file = Printf.sprintf "%s.dot" tmp_hash in
let annot_dot_file = Printf.sprintf "%s.dot_annot" tmp_hash in
let vbox = GPack.vbox () in
let hbox = GPack.hbox ~spacing:5 ~packing:(vbox#pack ~expand: false) () in
let _ = GMisc.label ~text: "Zoom:" ~packing: (hbox#pack ~padding: 4 ~expand: false) () in
let zooms =
[ 10 ; 20 ; 30 ; 40 ; 50 ; 60 ; 70 ; 80 ; 90 ; 100 ; 120 ]
in
let wcombo = GEdit.combo
~popdown_strings: (List.map (fun s -> Printf.sprintf "%d%%" s) zooms)
~allow_empty:false
~enable_arrow_keys:true
~value_in_list:true
~packing: (hbox#pack ~expand: false)
()
in
let wb_refresh = GButton.button ~label: "Refresh"
~packing: (hbox#pack ~expand: false ~padding: 4) ()
in
let wscroll = GBin.scrolled_window
~packing: (vbox#pack ~expand: true)
~hpolicy: `AUTOMATIC
~vpolicy: `AUTOMATIC
()
in
(* let _evt_box = GBin.event_box ~packing: wscroll#add_with_viewport () in*)
let canvas = GCan.canvas ~packing: wscroll#add () in
let border = 10. in
object(self)
val mutable current_zoom = 1.0
val mutable edges = []
val mutable nodes = []
val mutable graph = None
method virtual build_graph : Odot.graph
method virtual refresh_data : unit
method virtual on_button1_press : x: int -> y: int -> string option -> unit
method box = vbox
method input_zoom () =
let z =
try Scanf.sscanf wcombo#entry#text "%d%%" (fun a -> Some a)
with _ -> None
in
match z with
None -> ()
| Some n ->
current_zoom <- (float n) /. 100.;
canvas#set_pixels_per_unit current_zoom;
self#resize_text_items
method clean_files =
List.iter (fun f -> try Sys.remove f with _ -> ())
[ dot_file ; annot_dot_file ]
method load_graph file =
try
graph <- Some (Odot.parse_file file)
with Failure s -> GToolbox.message_box "Error" s
method resize_text_items =
let f_text t =
let font_size = float t.text_fontsize *. current_zoom in
if font_size <= 3.0 then
t.text_item#hide ()
else
(
t.text_item#set [`SIZE_POINTS font_size];
t.text_item#show ();
)
in
let f_node n =
match n.node_text with
None -> ()
| Some t -> f_text t
in
List.iter f_node nodes
method display () =
List.iter
(fun n ->
n.node_item#destroy ();
match n.node_text with Some t -> t.text_item#destroy () | None -> ()
) nodes;
nodes <- [];
match graph with
None -> ()
| Some g ->
canvas#set_pixels_per_unit current_zoom;
let (x1,y1,x2,y2) = get_graph_bounding_box g.Odot.stmt_list in
let (y1,y2) = (-y1, -y2) in
canvas#set_scroll_region
~x1:(float x1 -. border) ~y1:(float y1 -. border)
~x2:(float x2 +. border) ~y2:(float y2 +. border) ;
let rec f_stmt group props = function
[] -> ()
| Odot.Stmt_node ((id,_), attrs) :: q ->
let node = node_of_odot_node
self#on_button1_press self#on_button3_press
group props id attrs
in
nodes <- node :: nodes;
f_stmt group props q
| Odot.Stmt_attr (Odot.Attr_node attrs) :: q ->
let props = props_of_graph_node_attr props attrs in
f_stmt group props q
| Odot.Stmt_subgraph g2 :: q ->
let (node, group2) = create_subgraph
self#on_button1_press self#on_button3_press
group props g2
in
nodes <- node :: nodes;
f_stmt group2 props g2.Odot.sub_stmt_list;
f_stmt group props q
| Odot.Stmt_edge (src, l, attrs) :: q ->
let l_edges = edges_of_odot_edges group props (src :: l) attrs in
edges <- l_edges @ edges;
f_stmt group props q
| _ :: q ->
f_stmt group props q
in
f_stmt canvas#root default_props g.Odot.stmt_list;
canvas#misc#show ()
method refresh_dot () =
self#clean_files;
let g = self#build_graph in
Odot.print_file dot_file g;
let com = Printf.sprintf
"%s -s%d -y %s > %s"
(string_of_dot_program dot_program)
(int_of_float default_dot_ppi)
(Filename.quote dot_file)
(Filename.quote annot_dot_file)
in
(
match Sys.command com with
0 ->
self#load_graph annot_dot_file;
self#display ()
| n -> GToolbox.message_box "Error"
(Printf.sprintf "Exec error %d: %s" n com)
);
method refresh () =
self#refresh_data ;
self#refresh_dot ()
method on_button3_press ~x ~y _ =
let entries = List.map
(fun z ->
let t = Printf.sprintf "%d%%" z in
`I (t, fun () -> wcombo#entry#set_text t)
)
zooms
in
GToolbox.popup_menu ~entries ~button: 3 ~time: Int32.zero
initializer
ignore (vbox#connect#destroy (fun () -> self#clean_files));
wcombo#entry#set_editable false;
wcombo#entry#set_text "100%";
ignore (wcombo#entry#connect#changed self#input_zoom );
ignore (wb_refresh#connect#clicked self#refresh);
ignore
(canvas#event#connect#button_press ~callback:
(fun evt ->
match GdkEvent.Button.button evt with
| 3 ->
GdkEvent.get_type evt = `BUTTON_PRESS &&
(
let x = int_of_float (GdkEvent.Button.x evt) in
let y = int_of_float (GdkEvent.Button.y evt) in
self#on_button3_press x y None;
true
)
| n -> false
)
);
if not (Sys.file_exists annot_dot_file) then
self#refresh ()
else
(
self#refresh_data;
self#load_graph annot_dot_file;
self#display ()
)
end
*)