severe bug found in parallel zeta

[helm.git] / helm / software / matita / lablGraphviz.ml

diff --git a/helm/software/matita/lablGraphviz.ml b/helm/software/matita/lablGraphviz.ml
index d86d943e34a300a2ca266e2e9b0c343784437928..ab817e2940394c19a197810fecd79d6d825711f9 100644 (file)
--- a/helm/software/matita/lablGraphviz.ml
+++ b/helm/software/matita/lablGraphviz.ml
@@ -53,7 +53,9 @@ class graphviz_impl ?packing () =
     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)
@@ -89,16 +91,42 @@ class graphviz_impl ?packing () =
       let is_rect l = 
         try List.assoc "shape" l = "rect" with Not_found -> false
       in
-      let p =
+      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" 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
@@ -114,12 +142,13 @@ class graphviz_impl ?packing () =
 
     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;