tagging rc-1

[helm.git] / matita / lablGraphviz.ml

diff --git a/matita/lablGraphviz.ml b/matita/lablGraphviz.ml
index ac5cd7537577fa31f2d9b28bb0c2ec6f5cd5f676..d86d943e34a300a2ca266e2e9b0c343784437928 100644 (file)
--- a/matita/lablGraphviz.ml
+++ b/matita/lablGraphviz.ml
@@ -36,21 +36,29 @@ let tempfile () = Filename.temp_file "matita_" ""
 
 class type graphviz_widget =
   object
-    method load_graph_from_file: string -> unit
+    method load_graph_from_file: ?gviz_cmd:string -> string -> unit
     method connect_href:
       (GdkEvent.Button.t -> (string * string) list -> unit) -> unit
+    method center_on_href: string -> unit
     method as_image: GMisc.image
     method as_viewport: GBin.viewport
   end
 
-class graphviz_impl ?packing gviz_cmd =
+class graphviz_impl ?packing () =
   let viewport = GBin.viewport ?packing () in
+  let mk_gviz_cmd gviz_cmd flags src_fname dest_fname =
+    sprintf "cat %s | %s %s > %s" src_fname gviz_cmd flags
+      dest_fname in
   let image =
     GMisc.image ~packing:viewport#add ~xalign:0. ~yalign:0. ~xpad:0 ~ypad:0 ()
   in
+  let parse_coords s =
+    match List.map float_of_string (HExtlib.split ~sep:',' s) with
+    | [x1; y1; x2; y2 ] -> x1, y1, x2, y2
+    | _ -> assert false in
   object (self)
     val mutable href_cb = fun _ _ -> ()
-    val mutable map = []
+    val mutable map = []  (* list of associative list attr name -> attr value *)
 
     initializer
       ignore (viewport#event#connect#button_press (fun button ->
@@ -58,41 +66,41 @@ class graphviz_impl ?packing gviz_cmd =
         (* compute coordinates relative to image origin *)
         let x = GdkEvent.Button.x button +. viewport#hadjustment#value in
         let y = GdkEvent.Button.y button +. viewport#vadjustment#value in
-        (try
-          href_cb button (self#find_href x y)
-        with Not_found -> ());
+        (try href_cb button (self#find_href x y) with Not_found -> ());
         false))
 
-    method load_graph_from_file fname =
+    method load_graph_from_file ?(gviz_cmd = "dot") fname =
       let tmp_png = tempfile () in
-      ignore (Sys.command (sprintf "%s %s %s > %s"
-        gviz_cmd png_flags fname tmp_png));
+      let rc = Sys.command (mk_gviz_cmd gviz_cmd png_flags fname tmp_png) in
+      if rc <> 0 then
+        eprintf
+          ("Graphviz command failed (exit code: %d) on the following graph:\n"
+           ^^ "%s\n%!")
+          rc (HExtlib.input_file fname);
       image#set_file tmp_png;
       HExtlib.safe_remove tmp_png;
       let tmp_map = tempfile () in
-      ignore (Sys.command (sprintf "%s %s %s > %s"
-        gviz_cmd map_flags fname tmp_map));
+      ignore (Sys.command (mk_gviz_cmd gviz_cmd map_flags fname tmp_map));
       self#load_map tmp_map;
       HExtlib.safe_remove tmp_map
 
     method private load_map fname =
       let areas = ref [] in
+      let is_rect l = 
+        try List.assoc "shape" l = "rect" with Not_found -> false
+      in
       let p =
         XmlPushParser.create_parser
           { XmlPushParser.default_callbacks with
             XmlPushParser.start_element =
               Some (fun elt attrs ->
                 match elt with
-                | "area" -> areas := attrs :: !areas
+                | "area" when is_rect attrs -> areas := attrs :: !areas
                 | _ -> ()) } in
       XmlPushParser.parse p (`File fname);
       map <- !areas
 
     method private find_href x y =
-      let parse_coords s =
-        match List.map float_of_string (HExtlib.split ~sep:',' s) with
-        | [x1; y1; x2; y2 ] -> x1, y1, x2, y2
-        | _ -> assert false in
       List.find
         (fun attrs ->
           let x1, y1, x2, y2 = parse_coords (List.assoc "coords" attrs) in
@@ -104,53 +112,24 @@ class graphviz_impl ?packing gviz_cmd =
     =
       href_cb <- cb
 
+    method center_on_href href =
+      (*eprintf "Centering viewport on uri %s\n%!" href;*)
+      let attrs = 
+        List.find
+          (fun attrs ->
+            try List.assoc "href" attrs = href with Not_found -> false)
+          map in
+      try
+        let x1, y1, x2, y2 = parse_coords (List.assoc "coords" attrs) in
+        viewport#hadjustment#clamp_page ~lower:x1 ~upper:x2;
+        viewport#vadjustment#clamp_page ~lower:y1 ~upper:y2;
+      with Not_found -> ()
+
     method as_image = image
     method as_viewport = viewport
 
   end
 
-let factory cmd ?packing () =
-  (new graphviz_impl ?packing cmd :> graphviz_widget)
-
-let gDot = factory "dot"
-let gNeato = factory "neato"
-let gTwopi = factory "twopi"
-let gCirco = factory "circo"
-let gFdp = factory "fdp"
-
-module Pp =
-  struct
-
-    module type GraphvizFormatter =
-      sig
-        val header: ?name:string -> Format.formatter -> unit
-        val node: string -> ?attrs:(attribute list) -> Format.formatter -> unit
-        val edge:
-          string -> string -> ?attrs:(attribute list) -> Format.formatter ->
-            unit
-        val raw: string -> Format.formatter -> unit
-        val trailer: Format.formatter -> unit
-      end
-
-    open Format
-
-    module Dot =
-      struct
-        let attribute fmt (k, v) = fprintf fmt "@[<hv2>%s=@,\"%s\",@]" k v
-        let attributes attrs fmt = List.iter (attribute fmt) attrs
-
-        let header ?(name = "g") fmt = fprintf fmt "@[<hv2>digraph %s {@," name
-        let node name ?(attrs = []) fmt =
-          fprintf fmt "@[<hov2>%s@ [" name;
-          attributes attrs fmt;
-          fprintf fmt "];@]@,"
-        let edge name1 name2 ?(attrs = []) fmt =
-          fprintf fmt "@[<hov2>%s ->@ %s@ [" name1 name2;
-          attributes attrs fmt;
-          fprintf fmt "];@]@,"
-        let raw s fmt = pp_print_string fmt s
-        let trailer fmt = fprintf fmt "@,}@]%!"
-      end
-
-  end
+let graphviz ?packing () =
+  (new graphviz_impl ?packing () :> graphviz_widget)