X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fcic%2FcicUniv.ml;h=8ae118c9b1bb5ecf1d4c656ffcfb2bfb4ba15c86;hb=5104e38ee747fd1052ce21f3f9f2ecc778d590ba;hp=5616cb675daf9770bb84ad7edeee6b3fde82d4b6;hpb=533cbf996d38fabd40195e2184191d350b831ad2;p=helm.git

diff --git a/helm/ocaml/cic/cicUniv.ml b/helm/ocaml/cic/cicUniv.ml
index 5616cb675..8ae118c9b 100644
--- a/helm/ocaml/cic/cicUniv.ml
+++ b/helm/ocaml/cic/cicUniv.ml
@@ -34,11 +34,13 @@
 (*                                                                           *)
 (*****************************************************************************)
 
+(* $Id$ *)
+
 (*****************************************************************************)
 (** switch implementation                                                   **)
 (*****************************************************************************)
 
-let fast_implementation = ref false ;;
+let fast_implementation = ref true ;;
 
 (*****************************************************************************)
 (** open                                                                    **)
@@ -133,21 +135,6 @@ let string_of_mal m =
 let string_of_bag b = 
   string_of_mal b
 
-(*****************************************************************************)
-(** Helpers                                                                 **)
-(*****************************************************************************)
-
-(* find the repr *)
-let repr u m =
-  try 
-    MAL.find u m
-  with
-    Not_found -> empty_entry
-    
-(* FIXME: May be faster if we make it by hand *)
-let merge_closures f nodes m =  
-  SOF.fold (fun x i -> SOF.union (f (repr x m)) i ) nodes SOF.empty
-
 (*****************************************************************************)
 (** Benchmarking                                                            **)
 (*****************************************************************************)
@@ -167,7 +154,23 @@ let end_spending () =
     partial := 0.0;
     time_spent := !time_spent +. interval
 ;;
-  
+
+
+(*****************************************************************************)
+(** Helpers                                                                 **)
+(*****************************************************************************)
+
+(* find the repr *)
+let repr u m =
+  try 
+    MAL.find u m
+  with
+    Not_found -> empty_entry
+    
+(* FIXME: May be faster if we make it by hand *)
+let merge_closures f nodes m =  
+  SOF.fold (fun x i -> SOF.union (f (repr x m)) i ) nodes SOF.empty
+
 
 (*****************************************************************************)
 (** _fats implementation                                                    **)
@@ -272,7 +275,7 @@ and add_ge_arc_fast u v m =
   let rv = repr v m' in
   let rv' = {rv with in_gegt_of = SOF.add u rv.in_gegt_of} in
   let m'' = MAL.add v rv' m' in
-    adjust_fast u m''
+  adjust_fast u m''
 
 and add_eq_arc_fast u v m =
   let ru = repr u m in
@@ -411,7 +414,7 @@ let error arc node1 closure_type node2 closure =
   raise (UniverseInconsistency s)
 
 
-let fill_empty_nodes_with_uri g uri =
+let fill_empty_nodes_with_uri (g, already_contained) l uri =
   let fill_empty_universe u =
     match u with
         (i,None) -> (i,Some uri)
@@ -434,35 +437,44 @@ let fill_empty_nodes_with_uri g uri =
     fun k v m -> 
       MAL.add (fill_empty_universe k) (fill_empty_entry v) m) m MAL.empty
   in
-    m'
+  let l' = List.map fill_empty_universe l in
+    (m', already_contained),l'
 
 
 (*****************************************************************************)
 (** World interface                                                         **)
 (*****************************************************************************)
 
-type universe_graph = bag
+type universe_graph = bag * UriManager.UriSet.t 
+(* the graph , the cache of already merged ugraphs *)
 
-let empty_ugraph = empty_bag
+let empty_ugraph = empty_bag, UriManager.UriSet.empty
 
 let current_index_anon = ref (-1)
 let current_index_named = ref (-1)
 
 let restart_numbering () = current_index_named := (-1) 
 
-let fresh ?uri () =
+let fresh ?uri ?id () =
   let i =
-    match uri with
-    | None -> 
+    match uri,id with
+    | None,None -> 
         current_index_anon := !current_index_anon + 1;
         !current_index_anon
-    | Some _ -> 
+    | None, Some _ -> assert false
+    | Some _, None -> 
         current_index_named := !current_index_named + 1;
         !current_index_named
+    | Some _, Some id -> id
   in
   (i,uri)
 
-let print_ugraph g = 
+let name_universe u uri =
+  match u with
+  | (i, None) -> (i, Some uri)
+  | _ -> u
+  
+let print_ugraph (g, _) = 
   prerr_endline (string_of_bag g)
 
 let add_eq ?(fast=(!fast_implementation)) u v b =
@@ -521,67 +533,94 @@ let add_gt ?(fast=(!fast_implementation)) u v b =
 (** START: Decomment this for performance comparisons                       **)
 (*****************************************************************************)
 
-let add_eq ?(fast=(!fast_implementation))  u v b =
+let add_eq ?(fast=(!fast_implementation))  u v (b,already_contained) =
+  (*prerr_endline "add_eq";*)
   begin_spending ();
   let rc = add_eq ~fast u v b in
-    end_spending();
-    rc
+  end_spending ();
+    rc,already_contained
 
-let add_ge ?(fast=(!fast_implementation)) u v b =
+let add_ge ?(fast=(!fast_implementation)) u v (b,already_contained) =
+(*   prerr_endline "add_ge"; *)
   begin_spending ();
   let rc = add_ge ~fast u v b in
- end_spending();
-    rc
+  end_spending ();
+    rc,already_contained
     
-let add_gt ?(fast=(!fast_implementation)) u v b =
+let add_gt ?(fast=(!fast_implementation)) u v (b,already_contained) =
+(*   prerr_endline "add_gt"; *)
   begin_spending ();
   let rc = add_gt ~fast u v b in
-    end_spending();
-    rc
+  end_spending ();
+    rc,already_contained
+    
+let profiler_eq = HExtlib.profile "CicUniv.add_eq"
+let profiler_ge = HExtlib.profile "CicUniv.add_ge"
+let profiler_gt = HExtlib.profile "CicUniv.add_gt"
+let add_gt ?fast u v b = 
+  profiler_gt.HExtlib.profile (fun _ -> add_gt ?fast u v b) ()
+let add_ge ?fast u v b = 
+  profiler_ge.HExtlib.profile (fun _ -> add_ge ?fast u v b) ()
+let add_eq ?fast u v b = 
+  profiler_eq.HExtlib.profile (fun _ -> add_eq ?fast u v b) ()
 
 (*****************************************************************************)
 (** END: Decomment this for performance comparisons                         **)
 (*****************************************************************************)
 
-let merge_ugraphs u v =
-  (* this sucks *)
-  let merge_brutal u v =
-    if u = empty_bag then v 
-    else if v = empty_bag then u 
-    else
-      let m1 = u in 
-      let m2 = v in 
-        MAL.fold (
-          fun k v x -> 
-            (SOF.fold (
-               fun u x -> 
-                 let m = add_gt k u x in m) v.one_s_gt 
-               (SOF.fold (
-                  fun u x -> 
-                    let m = add_ge k u x in m) v.one_s_ge
-                  (SOF.fold (
-                     fun u x -> 
-                       let m = add_eq k u x in m) v.one_s_eq x)))
-        ) m1 m2
+let merge_ugraphs ~base_ugraph ~increment:(increment, uri_of_increment) =
+  let merge_brutal (u,_) v =
+    let m1 = u in 
+    let m2 = v in 
+      MAL.fold (
+        fun k v x -> 
+          (SOF.fold (
+             fun u x -> 
+               let m = add_gt k u x in m) 
+                (SOF.union v.one_s_gt v.gt_closure)
+             (SOF.fold (
+                fun u x -> 
+                  let m = add_ge k u x in m) 
+                    (SOF.union v.one_s_ge v.ge_closure)
+                (SOF.fold (
+                   fun u x ->
+                     let m = add_eq k u x in m) 
+                      (SOF.union v.one_s_eq v.eq_closure) x)))
+          ) m1 m2
   in
-    merge_brutal u v
+  let base, already_contained = base_ugraph in
+  if MAL.is_empty base then
+    increment
+  else if 
+    MAL.is_empty (fst increment) || 
+    UriManager.UriSet.mem uri_of_increment already_contained 
+  then
+    base_ugraph
+  else
+    fst (merge_brutal increment base_ugraph), 
+    UriManager.UriSet.add uri_of_increment already_contained
 
+let profiler_merge = HExtlib.profile "CicUniv.merge_graphs"
+let merge_ugraphs ~base_ugraph ~increment =
+  profiler_merge.HExtlib.profile 
+  (fun _ -> merge_ugraphs ~base_ugraph ~increment) ()
 
 (*****************************************************************************)
 (** Xml sesialization and parsing                                           **)
 (*****************************************************************************)
 
+let xml_of_universe name u = 
+  match u with
+  | (i,Some u) -> 
+      Xml.xml_empty name [
+        None,"id",(string_of_int i) ;
+        None,"uri",(UriManager.string_of_uri u)]
+  | (_,None) -> 
+      raise (Failure "we can serialize only universes with uri")
+
 let xml_of_set s =
   let l = 
-    List.map (
-      function 
-          (i,Some u) -> 
-            Xml.xml_empty "node" [
-              None,"id",(string_of_int i) ;
-              None,"uri",(UriManager.string_of_uri u)]
-        | (_,None) -> 
-            raise (Failure "we can serialize only universes with uri")
-    ) (SOF.elements s) 
+    List.map (xml_of_universe "node") (SOF.elements s) 
   in
     List.fold_left (fun s x -> [< s ; x >] ) [<>] l
       
@@ -617,17 +656,21 @@ let xml_of_entry u e =
   let content = xml_of_entry_content e in
   ent content
 
-let write_xml_of_ugraph filename m =
-    let o = open_out filename in
-    output_string o "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>\n";
-    Xml.pp_to_outchan (
-      Xml.xml_nempty "ugraph" [] (
-      MAL.fold (
-        fun k v s -> [< s ; (xml_of_entry k v) >])
-      m [<>])) o;
-    close_out o
+let write_xml_of_ugraph filename (m,_) l =
+    let tokens = 
+      [< 
+        Xml.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n";
+        Xml.xml_nempty "ugraph" [] 
+          ([< (MAL.fold ( fun k v s -> [< s ; (xml_of_entry k v) >]) m [<>]) ; 
+           (List.fold_left 
+             (fun s u -> [< s ; xml_of_universe "owned_node" u >]) [<>] l) >])>]
+    in
+    Xml.pp ~gzip:true tokens (Some filename)
+
+let univno = fst
+
  
-let rec clean_ugraph m f =
+let rec clean_ugraph (m,already_contained) f =
   let m' = 
     MAL.fold (fun k v x -> if (f k) then MAL.add k v x else x ) m MAL.empty in
   let m'' =  MAL.fold (fun k v x -> 
@@ -642,12 +685,18 @@ let rec clean_ugraph m f =
     } in 
     MAL.add k v' x ) m' MAL.empty in
   let e_l = 
-    MAL.fold (fun k v l -> if v = empty_entry then k::l else l) m'' []
+    MAL.fold (fun k v l -> if v = empty_entry && not(f k) then
+      begin
+      k::l end else l) m'' []
   in
     if e_l != [] then
-      clean_ugraph m'' (fun u -> (f u) && not (List.mem u e_l))
+      clean_ugraph 
+        (m'', already_contained) (fun u -> (f u) && not (List.mem u e_l))
     else
-      m''
+      MAL.fold 
+        (fun k v x -> if v <> empty_entry then MAL.add k v x else x) 
+        m'' MAL.empty,
+      already_contained
 
 let clean_ugraph g l =
   clean_ugraph g (fun u -> List.mem u l)
@@ -664,11 +713,11 @@ let assigner_of =
   | s -> raise (Failure ("unsupported tag " ^ s))
 ;;
 
-let cb_factory m = 
+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_ge_of") in
+  let current_assign = ref (assigner_of "in_gegt_of") in
   { XPP.default_callbacks with
     XPP.end_element = Some( fun name ->
       match name with
@@ -679,6 +728,7 @@ let cb_factory m =
     );
     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
@@ -688,67 +738,25 @@ let cb_factory m =
           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
     )
   }
 ;; 
 
-(* alternative implementation *)
-let mapl = [
-  ("ge_closure",0);("gt_closure",1);("eq_closure",2);
-  ("in_gegt_of",  3);
-  ("one_s_ge",  4);("one_s_gt",  5);("one_s_eq",  6)]
-;;
-
-let assigner_of' s = List.assoc s mapl ;;
-
-let entry_of_array a = { 
-  ge_closure = a.(0); gt_closure = a.(1); eq_closure = a.(2);
-  in_gegt_of   = a.(3); 
-  one_s_ge   = a.(4); one_s_gt   = a.(5); one_s_eq   = a.(6)}
-;;
-
-let cb_factory' m = 
-  let module XPP = XmlPushParser in
-  let current_node = ref (0,None) in
-  let current_entry = Array.create 7 SOF.empty in
-  let current_assign = ref 0 in
-  { XPP.default_callbacks with
-    XPP.start_element = Some( fun name attlist ->
-      match name with
-      | "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) <- 
-            SOF.add (id,Some (UriManager.uri_of_string uri)) 
-              current_entry.(!current_assign) 
-      | s -> current_assign := assigner_of' s
-    );
-    XPP.end_element = Some( fun name -> 
-      match name with
-      | "entry" -> 
-          m := MAL.add !current_node (entry_of_array current_entry) !m;
-          Array.fill current_entry 0 7 SOF.empty 
-      | _ -> ()
-    );
-  }
-;;
-
-     
-let ugraph_of_xml filename =
+let ugraph_and_univlist_of_xml filename =
   let module XPP = XmlPushParser in
-  let result = ref MAL.empty in
-  let cb = cb_factory result in
-(*let cb = cb_factory' result 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
+  (!result_map,UriManager.UriSet.empty), !result_list
 
 
 (*****************************************************************************)
@@ -920,18 +928,24 @@ let recons_entry entry =
     one_s_gt = recons_set entry.one_s_gt;
   }
 
-let recons_graph graph =
+let recons_graph (graph,uriset) =
   MAL.fold
     (fun universe entry map ->
       MAL.add (recons_univ universe) (recons_entry entry) map)
-    graph MAL.empty
+    graph 
+    MAL.empty,
+  UriManager.UriSet.fold 
+    (fun u acc -> 
+      UriManager.UriSet.add 
+        (UriManager.uri_of_string (UriManager.string_of_uri u)) acc) 
+    uriset UriManager.UriSet.empty 
 
 let assert_univ u =
     match u with 
     | (_,None) -> raise (UniverseInconsistency "This universe graph has a hole")
     | _ -> ()
     
-let assert_univs_have_uri graph =
+let assert_univs_have_uri (graph,_) univlist =
   let assert_set s =
     SOF.iter (fun u -> assert_univ u) s
   in
@@ -944,7 +958,25 @@ let assert_univs_have_uri graph =
     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 
+  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 *)