X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fmatita%2FlablGraphviz.ml;h=ab817e2940394c19a197810fecd79d6d825711f9;hb=647b419e96770d90a82d7a9e5e8843566a9f93ee;hp=12d302d244ab182a97981240dc66fe4141517257;hpb=78e39847d4e846421ccb10cda72f1b690550deb1;p=helm.git

diff --git a/helm/software/matita/lablGraphviz.ml b/helm/software/matita/lablGraphviz.ml
index 12d302d24..ab817e294 100644
--- a/helm/software/matita/lablGraphviz.ml
+++ b/helm/software/matita/lablGraphviz.ml
@@ -31,13 +31,12 @@ type attribute = string * string  (* <key, value> pair *)
 
 let png_flags = "-Tpng"
 let map_flags = "-Tcmapx"
-let tred_cmd = "tred" (* graphviz transitive reduction filter *)
 
 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
@@ -45,16 +44,18 @@ class type graphviz_widget =
     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 flags src_fname dest_fname =
-    sprintf "cat %s | %s | %s %s > %s" src_fname tred_cmd gviz_cmd flags
+  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
+    let xys = HExtlib.split ~sep:' ' s in
+    let xys = List.flatten (List.map (HExtlib.split ~sep:',') xys) in
+    match List.map float_of_string xys with
     | [x1; y1; x2; y2 ] -> x1, y1, x2, y2
     | _ -> assert false in
   object (self)
@@ -70,9 +71,9 @@ class graphviz_impl ?packing gviz_cmd =
         (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
-      let rc = Sys.command (mk_gviz_cmd png_flags fname tmp_png) in
+      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"
@@ -81,22 +82,51 @@ class graphviz_impl ?packing gviz_cmd =
       image#set_file tmp_png;
       HExtlib.safe_remove tmp_png;
       let tmp_map = tempfile () in
-      ignore (Sys.command (mk_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 p =
+      let is_rect l = 
+        try List.assoc "shape" l = "rect" with Not_found -> false
+      in
+      let is_poly l = 
+        try List.assoc "shape" l = "poly" with Not_found -> false
+      in
+      let rectify l = 
+        List.map (
+         function "coords",c -> 
+          let xys = HExtlib.split ~sep:' ' c in
+          let xys = 
+            List.map 
+              (fun s -> 
+                 match HExtlib.split ~sep:',' s with 
+                 | [x; y] -> int_of_string x, int_of_string y 
+                 | _ -> assert false)
+              xys
+          in
+          let xs, ys = List.split xys in
+          let max_x = string_of_int (List.fold_left max 0 xs) in
+          let max_y = string_of_int (List.fold_left max 0 ys) in
+          let min_x = string_of_int (List.fold_left min max_int xs) in
+          let min_y = string_of_int (List.fold_left min max_int ys) in
+          "coords", min_x^","^min_y^" "^max_x^","^max_y
+         | x -> x) l
+      in
+      try
+       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
+                | "area" when is_poly attrs -> areas := rectify attrs :: !areas
                 | _ -> ()) } in
-      XmlPushParser.parse p (`File fname);
-      map <- !areas
+       XmlPushParser.parse p (`File fname);
+       map <- !areas  
+      with XmlPushParser.Parse_error _ -> ()
 
     method private find_href x y =
       List.find
@@ -112,12 +142,13 @@ class graphviz_impl ?packing gviz_cmd =
 
     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 attrs = 
+          List.find
+            (fun attrs ->
+              try List.assoc "href" attrs = href with Not_found -> false)
+          map 
+        in
         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;
@@ -128,12 +159,6 @@ class graphviz_impl ?packing gviz_cmd =
 
   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"
+let graphviz ?packing () =
+  (new graphviz_impl ?packing () :> graphviz_widget)