+ if e_l != [] then
+ clean_ugraph m'' (fun u -> (f u) && not (List.mem u e_l))
+ else
+ m''
+
+let clean_ugraph g l =
+ clean_ugraph g (fun u -> List.mem u l)
+
+let assigner_of =
+ function
+ "ge_closure" -> (fun e u->{e with ge_closure=SOF.add u e.ge_closure})
+ | "gt_closure" -> (fun e u->{e with gt_closure=SOF.add u e.gt_closure})
+ | "eq_closure" -> (fun e u->{e with eq_closure=SOF.add u e.eq_closure})
+ | "in_gegt_of" -> (fun e u->{e with in_gegt_of =SOF.add u e.in_gegt_of})
+ | "one_s_ge" -> (fun e u->{e with one_s_ge =SOF.add u e.one_s_ge})
+ | "one_s_gt" -> (fun e u->{e with one_s_gt =SOF.add u e.one_s_gt})
+ | "one_s_eq" -> (fun e u->{e with one_s_eq =SOF.add u e.one_s_eq})
+ | s -> raise (Failure ("unsupported tag " ^ s))
+;;
+
+let cb_factory m l =
+ let module XPP = XmlPushParser in
+ let current_node = ref (0,None) in
+ let current_entry = ref empty_entry in
+ let current_assign = ref (assigner_of "in_gegt_of") in
+ { XPP.default_callbacks with
+ XPP.end_element = Some( fun name ->
+ match name with
+ | "entry" ->
+ m := MAL.add !current_node !current_entry !m;
+ current_entry := empty_entry
+ | _ -> ()
+ );
+ XPP.start_element = Some( fun name attlist ->
+ match name with
+ | "ugraph" -> ()
+ | "entry" ->
+ let id = List.assoc "id" attlist in
+ let uri = List.assoc "uri" attlist in
+ current_node := (int_of_string id,Some (UriManager.uri_of_string uri))
+ | "node" ->
+ let id = int_of_string (List.assoc "id" attlist) in
+ let uri = List.assoc "uri" attlist in
+ current_entry := !current_assign !current_entry
+ (id,Some (UriManager.uri_of_string uri))
+ | "owned_node" ->
+ let id = int_of_string (List.assoc "id" attlist) in
+ let uri = List.assoc "uri" attlist in
+ l := (id,Some (UriManager.uri_of_string uri)) :: !l
+ | s -> current_assign := assigner_of s
+ )
+ }
+;;
+
+let ugraph_and_univlist_of_xml filename =
+ let module XPP = XmlPushParser in
+ let result_map = ref MAL.empty in
+ let result_list = ref [] in
+ let cb = cb_factory result_map result_list in
+ let xml_parser = XPP.create_parser cb in
+ let xml_source = `Gzip_file filename in
+ (try XPP.parse xml_parser xml_source
+ with (XPP.Parse_error err) as exn -> raise exn);
+ !result_map, !result_list
+
+\f
+(*****************************************************************************)
+(** the main, only for testing **)
+(*****************************************************************************)
+
+(*
+
+type arc = Ge | Gt | Eq ;;
+
+let randomize_actionlist n m =
+ let ge_percent = 0.7 in
+ let gt_percent = 0.15 in
+ let random_step () =
+ let node1 = Random.int m in
+ let node2 = Random.int m in
+ let op =
+ let r = Random.float 1.0 in
+ if r < ge_percent then
+ Ge
+ else (if r < (ge_percent +. gt_percent) then
+ Gt
+ else
+ Eq)
+ in
+ op,node1,node2
+ in
+ let rec aux n =
+ match n with
+ 0 -> []
+ | n -> (random_step ())::(aux (n-1))
+ in
+ aux n
+
+let print_action_list l =
+ let string_of_step (op,node1,node2) =
+ (match op with
+ Ge -> "Ge"
+ | Gt -> "Gt"
+ | Eq -> "Eq") ^
+ "," ^ (string_of_int node1) ^ "," ^ (string_of_int node2)
+ in
+ let rec aux l =
+ match l with
+ [] -> "]"
+ | a::tl ->
+ ";" ^ (string_of_step a) ^ (aux tl)
+ in
+ let body = aux l in
+ let l_body = (String.length body) - 1 in
+ prerr_endline ("[" ^ (String.sub body 1 l_body))
+
+let debug = false
+let d_print_endline = if debug then print_endline else ignore
+let d_print_ugraph = if debug then print_ugraph else ignore
+
+let _ =
+ (if Array.length Sys.argv < 2 then
+ prerr_endline ("Usage " ^ Sys.argv.(0) ^ " max_edges max_nodes"));
+ Random.self_init ();
+ let max_edges = int_of_string Sys.argv.(1) in
+ let max_nodes = int_of_string Sys.argv.(2) in
+ let action_listR = randomize_actionlist max_edges max_nodes in
+
+ let action_list = [Ge,1,4;Ge,2,6;Ge,1,1;Eq,6,4;Gt,6,3] in
+ let action_list = action_listR in
+
+ print_action_list action_list;
+ let prform_step ?(fast=false) (t,u,v) g =
+ let f,str =
+ match t with
+ Ge -> add_ge,">="
+ | Gt -> add_gt,">"
+ | Eq -> add_eq,"="
+ in
+ d_print_endline (
+ "Aggiungo " ^
+ (string_of_int u) ^
+ " " ^ str ^ " " ^
+ (string_of_int v));
+ let g' = f ~fast (u,None) (v,None) g in
+ (*print_ugraph g' ;*)
+ g'
+ in
+ let fail = ref false in
+ let time1 = Unix.gettimeofday () in
+ let n_safe = ref 0 in
+ let g_safe =
+ try
+ d_print_endline "SAFE";
+ List.fold_left (
+ fun g e ->
+ n_safe := !n_safe + 1;
+ prform_step e g
+ ) empty_ugraph action_list
+ with
+ UniverseInconsistency s -> fail:=true;empty_bag
+ in
+ let time2 = Unix.gettimeofday () in
+ d_print_ugraph g_safe;
+ let time3 = Unix.gettimeofday () in
+ let n_test = ref 0 in
+ let g_test =
+ try
+ d_print_endline "FAST";
+ List.fold_left (
+ fun g e ->
+ n_test := !n_test + 1;
+ prform_step ~fast:true e g
+ ) empty_ugraph action_list
+ with
+ UniverseInconsistency s -> empty_bag
+ in
+ let time4 = Unix.gettimeofday () in
+ d_print_ugraph g_test;
+ if are_ugraph_eq g_safe g_test && !n_test = !n_safe then
+ begin
+ let num_eq =
+ List.fold_left (
+ fun s (e,_,_) ->
+ if e = Eq then s+1 else s
+ ) 0 action_list
+ in
+ let num_gt =
+ List.fold_left (
+ fun s (e,_,_) ->
+ if e = Gt then s+1 else s
+ ) 0 action_list
+ in
+ let num_ge = max_edges - num_gt - num_eq in
+ let time_fast = (time4 -. time3) in
+ let time_safe = (time2 -. time1) in
+ let gap = ((time_safe -. time_fast) *. 100.0) /. time_safe in
+ let fail = if !fail then 1 else 0 in
+ print_endline
+ (sprintf
+ "OK %d safe %1.4f fast %1.4f %% %1.2f #eq %d #gt %d #ge %d %d"
+ fail time_safe time_fast gap num_eq num_gt num_ge !n_safe);
+ exit 0
+ end
+ else
+ begin
+ print_endline "FAIL";
+ print_ugraph g_safe;
+ print_ugraph g_test;
+ exit 1
+ end
+;;
+
+ *)
+
+let recons_univ u =
+ match u with
+ | i, None -> u
+ | i, Some uri ->
+ i, Some (UriManager.uri_of_string (UriManager.string_of_uri uri))
+
+let recons_entry entry =
+ let recons_set set =
+ SOF.fold (fun univ set -> SOF.add (recons_univ univ) set) set SOF.empty
+ in
+ {
+ eq_closure = recons_set entry.eq_closure;
+ ge_closure = recons_set entry.ge_closure;
+ gt_closure = recons_set entry.gt_closure;
+ in_gegt_of = recons_set entry.in_gegt_of;
+ one_s_eq = recons_set entry.one_s_eq;
+ one_s_ge = recons_set entry.one_s_ge;
+ one_s_gt = recons_set entry.one_s_gt;
+ }
+
+let recons_graph graph =
+ MAL.fold
+ (fun universe entry map ->
+ MAL.add (recons_univ universe) (recons_entry entry) map)
+ graph MAL.empty
+
+let assert_univ u =
+ match u with
+ | (_,None) -> raise (UniverseInconsistency "This universe graph has a hole")
+ | _ -> ()
+
+let assert_univs_have_uri graph univlist =
+ let assert_set s =
+ SOF.iter (fun u -> assert_univ u) s
+ in
+ let assert_entry e =
+ assert_set e.eq_closure;
+ assert_set e.ge_closure;
+ assert_set e.gt_closure;
+ assert_set e.in_gegt_of;
+ assert_set e.one_s_eq;
+ assert_set e.one_s_ge;
+ assert_set e.one_s_gt;
+ in
+ MAL.iter (fun k v -> assert_univ k; assert_entry v)graph;
+ List.iter assert_univ univlist
+
+let eq u1 u2 =
+ match u1,u2 with
+ | (id1, Some uri1),(id2, Some uri2) ->
+ id1 = id2 && UriManager.eq uri1 uri2
+ | (id1, None),(id2, None) -> id1 = id2
+ | _ -> false
+
+let compare (id1, uri1) (id2, uri2) =
+ let cmp = id1 - id2 in
+ if cmp = 0 then
+ match uri1,uri2 with
+ | None, None -> 0
+ | Some _, None -> 1
+ | None, Some _ -> ~-1
+ | Some uri1, Some uri2 -> UriManager.compare uri1 uri2
+ else
+ cmp
+
+(* EOF *)