X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fmetadata%2FmetadataDeps.ml;h=bf1dc49e0ec2d8213577f31a275aa27e4e2ad1f2;hb=66929b8edb58d468a134b648466f3e9c45ba5c0e;hp=0e1dbb817c45ef39bf8de27a43d81bab315bf13c;hpb=327d441ca9c875f251c5b0aabe74f997a12075e1;p=helm.git

diff --git a/helm/software/components/metadata/metadataDeps.ml b/helm/software/components/metadata/metadataDeps.ml
index 0e1dbb817..bf1dc49e0 100644
--- a/helm/software/components/metadata/metadataDeps.ml
+++ b/helm/software/components/metadata/metadataDeps.ml
@@ -65,9 +65,9 @@ let direct_deps ~dbd uri =
           assert false 
   in
   let do_query tbl =
-    let res = HMysql.exec dbd (SqlStatements.direct_deps tbl uri) in
+    let res = HSql.exec dbd (SqlStatements.direct_deps tbl uri) in
     let deps =
-      HMysql.map res (fun row -> unbox_row (obj_metadata_of_row row)) in
+      HSql.map res (fun row -> unbox_row (obj_metadata_of_row row)) in
     deps
   in
   do_query (MetadataTypes.obj_tbl ())
@@ -83,14 +83,53 @@ let inverse_deps ~dbd uri =
           assert false 
   in
   let do_query tbl =
-    let res = HMysql.exec dbd (SqlStatements.inverse_deps tbl uri) in
+    let res = HSql.exec dbd (SqlStatements.inverse_deps tbl uri) in
     let deps =
-      HMysql.map res (fun row -> unbox_row (inv_obj_metadata_of_row row)) in
+      HSql.map res (fun row -> unbox_row (inv_obj_metadata_of_row row)) in
     deps
   in
   do_query (MetadataTypes.obj_tbl ())
     @ do_query MetadataTypes.library_obj_tbl
 
+let topological_sort ~dbd uris =
+ let module OrderedUri =
+  struct
+   type t = UriManager.uri
+   let compare = UriManager.compare
+  end in
+ let module Topo = HTopoSort.Make(OrderedUri) in
+  Topo.topological_sort uris
+   (fun uri -> fst (List.split (direct_deps ~dbd uri)))
+
+let sorted_uris_of_baseuri ~dbd baseuri =
+   let sql_pat = 
+     Pcre.replace ~pat:"([^\\\\])_" ~templ:"$1\\_" baseuri ^ "%"
+   in
+   let query =
+      Printf.sprintf
+         ("SELECT source FROM %s WHERE source LIKE \"%s\" ESCAPE \"\\\" UNION "
+           ^^
+          "SELECT source FROM %s WHERE source LIKE \"%s\" ESCAPE \"\\\"")
+         (MetadataTypes.name_tbl ()) sql_pat
+         MetadataTypes.library_name_tbl sql_pat
+   in
+   let result = HSql.exec dbd query in
+   let map cols = match cols.(0) with
+      | Some s -> UriManager.uri_of_string s
+      | _ -> assert false
+   in
+   let uris = HSql.map result map in
+   let sorted_uris = topological_sort ~dbd uris in
+   let filter_map uri =
+      let s =
+         Pcre.replace ~rex:(Pcre.regexp "#xpointer\\(1/1\\)") ~templ:""
+                      (UriManager.string_of_uri uri)
+      in
+      try ignore (Pcre.exec ~rex:(Pcre.regexp"#xpointer") s); None
+      with Not_found -> Some (UriManager.uri_of_string s)
+   in
+   HExtlib.filter_map filter_map sorted_uris
+
 module DepGraph =
 struct
   module UriTbl = UriManager.UriHashtbl
@@ -98,7 +137,10 @@ struct
   let fat_value = 20
   let fat_increment = fat_value
   let incomplete_attrs = ["style", "dashed"]
-  let global_node_attrs = ["fontsize", "9"; "width", ".4"; "height", ".4"]
+  let global_node_attrs = ["fontsize", "12"; "width", ".4"; "height", ".4"]
+
+  let label_of_uri uri = UriManager.name_of_uri uri
+  (*let label_of_uri uri = UriManager.string_of_uri uri*)
 
   type neighborhood =
     { adjacency: UriManager.uri list lazy_t;  (* all outgoing edges *)
@@ -129,7 +171,7 @@ struct
         (*eprintf "Node '%s' not found.\n" (UriManager.string_of_uri uri);*)
         assert false
     in
-    Pp.header ~graph_attrs:["rankdir", "LR"] ~node_attrs:global_node_attrs fmt;
+    Pp.header ~graph_type:"strict digraph" ~graph_attrs:["rankdir", "LR"] ~node_attrs:global_node_attrs fmt;
     let rec aux =
       function
         | [] -> ()
@@ -137,7 +179,7 @@ struct
             let suri = UriManager.string_of_uri uri in
             Pp.node suri
               ~attrs:([ "href", UriManager.string_of_uri uri;
-                       (*"label", UriManager.name_of_uri uri*)
+                        "label", label_of_uri uri
                 ] @ (if is_complete uri then [] else incomplete_attrs))
               fmt;
             let new_nodes = ref [] in
@@ -205,9 +247,16 @@ struct
       [], 0
 
   let collapse uri (adjlist, _root, f, _invert) =
+    try
+      let neighbs = UriTbl.find adjlist uri in
+      if Lazy.lazy_is_val neighbs.adjacency then
+        (* do not collapse already collapsed nodes *)
+        if Lazy.force neighbs.adjacency <> [] then
+          (* do not collapse nodes with no outgoing edges *)
+          UriTbl.replace adjlist uri { adjacency = lazy (f uri); shown = 0 }
+    with Not_found ->
       (* do not add a collapsed node if it was not part of the graph *)
-    if UriTbl.mem adjlist uri then
-      UriTbl.replace adjlist uri { adjacency = lazy (f uri); shown = 0 }
+      ()
 
   let graph_of_fun ?(invert = false) f ~dbd uri =
     let f ~dbd uri =