X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=matita%2FlablGraphviz.ml;h=ac5cd7537577fa31f2d9b28bb0c2ec6f5cd5f676;hb=c97fb85c9e568dfb4459a7118fcba2db38f5654c;hp=fab25cba658047fa23d92c3f0c7458b7b97fb720;hpb=c48b5aad2194bb8296bfbbb8ba6766bc6e578c2e;p=helm.git

diff --git a/matita/lablGraphviz.ml b/matita/lablGraphviz.ml
index fab25cba6..ac5cd7537 100644
--- a/matita/lablGraphviz.ml
+++ b/matita/lablGraphviz.ml
@@ -27,6 +27,8 @@
 
 open Printf
 
+type attribute = string * string  (* <key, value> pair *)
+
 let png_flags = "-Tpng"
 let map_flags = "-Tcmapx"
 
@@ -66,11 +68,12 @@ class graphviz_impl ?packing gviz_cmd =
       ignore (Sys.command (sprintf "%s %s %s > %s"
         gviz_cmd png_flags fname tmp_png));
       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));
       self#load_map tmp_map;
-      HExtlib.safe_remove tmp_png
+      HExtlib.safe_remove tmp_map
 
     method private load_map fname =
       let areas = ref [] in
@@ -115,3 +118,39 @@ 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
+