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 ())
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 ~rex:(Pcre.regexp "_") ~templ:"\\_" baseuri ^ "%"
+ in
+ let query =
+ Printf.sprintf
+ ("SELECT source FROM %s WHERE source LIKE \"%s\" UNION "^^
+ "SELECT source FROM %s WHERE source LIKE \"%s\"")
+ (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
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 *)
(*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
| [] -> ()
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
adjacency;
neighbs.shown <- weight;
fst (HExtlib.split_nth weight adjacency), weight
- else (* nodes has been expanded at least once *)
+ else begin (* nodes has been expanded at least once *)
let adjacency = Lazy.force neighbs.adjacency in
let total_nodes = List.length adjacency in
if neighbs.shown < total_nodes then begin
(* some more children to show ... *)
let shown_before = neighbs.shown in
neighbs.shown <- min (neighbs.shown + fat_increment) total_nodes;
- let new_shown = shown_before - neighbs.shown in
+ let new_shown = neighbs.shown - shown_before in
(fst (HExtlib.split_nth new_shown (List.rev adjacency))), new_shown
end else
[], 0 (* all children are already shown *)
+ end
with Not_found ->
(*eprintf "uri not found: %s\n%!" (UriManager.string_of_uri uri);*)
[], 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 =