milestone in basic_2, λδ-2A reconstructed

[helm.git] / helm / software / components / tactics / auto.ml

diff --git a/helm/software/components/tactics/auto.ml b/helm/software/components/tactics/auto.ml
index dda3ee9332755332862ec844f7154fba7e8666b4..a89bbd4a164b9e1c673b9ea9a7a0e2620788904d 100644 (file)
--- a/helm/software/components/tactics/auto.ml
+++ b/helm/software/components/tactics/auto.ml
@@ -38,12 +38,14 @@ let ppterm ctx t =
   let names = List.map (function None -> None | Some (x,_) -> Some x) ctx in
   CicPp.pp t names
 ;;
+
 let is_propositional context sort = 
   match CicReduction.whd context sort with
   | Cic.Sort Cic.Prop 
   | Cic.Sort (Cic.CProp _) -> true
   | _-> false
 ;;
+
 let is_in_prop context subst metasenv ty =
   let sort,u = typeof ~subst metasenv context ty CicUniv.oblivion_ugraph in
   is_propositional context sort
@@ -139,7 +141,7 @@ let is_an_equational_goal = function
   | _ -> false
 ;;
 
-type auto_params = Cic.term list * (string * string) list 
+type auto_params = Cic.term list option * (string * string) list 
 
 let elems = ref [] ;;
 
@@ -375,52 +377,53 @@ let init_cache_and_tables
            metasenv subst context t None)
       automation_cache ct
   in
-  if restricted_univ = [] then
-    let ct = 
-      if use_context then find_context_theorems context metasenv else [] 
-    in
-    let lt = 
-      match use_library, dbd with
-      | true, Some dbd -> find_library_theorems dbd metasenv goal 
-      | _ -> []
-    in
-    let cache = AutoCache.cache_empty in
-    let cache = cache_add_list cache context (ct@lt) in  
-    let automation_cache = 
-      add_list_to_tables metasenv subst automation_cache ct 
-    in
+  match restricted_univ with
+    | None ->
+       let ct = 
+         if use_context then find_context_theorems context metasenv else [] 
+       in
+       let lt = 
+         match use_library, dbd with
+           | true, Some dbd -> find_library_theorems dbd metasenv goal 
+           | _ -> []
+       in
+       let cache = AutoCache.cache_empty in
+       let cache = cache_add_list cache context (ct@lt) in  
+       let automation_cache = 
+         add_list_to_tables metasenv subst automation_cache ct 
+       in
 (*     AutomationCache.pp_cache automation_cache; *)
-    automation_cache.AutomationCache.univ, 
-    automation_cache.AutomationCache.tables, 
-    cache
-  else
-    let t_ty = 
-      List.map
-        (fun  t ->
-          let ty, _ = CicTypeChecker.type_of_aux' 
-            metasenv ~subst:[] context t CicUniv.oblivion_ugraph
-          in
-            t, ty)
-        restricted_univ
-    in
-    (* let automation_cache = AutomationCache.empty () in *) 
-    let automation_cache = 
-      let universe = Universe.empty in
-      let universe = 
-        Universe.index_list universe context t_ty
-      in
-      { automation_cache with AutomationCache.univ = universe }
-    in
-    let ct = 
-     if use_context then find_context_theorems context metasenv else t_ty
-    in
-    let automation_cache = 
-      add_list_to_tables metasenv subst automation_cache ct
-    in
+         automation_cache.AutomationCache.univ, 
+       automation_cache.AutomationCache.tables, 
+       cache
+    | Some restricted_univ ->
+       let t_ty = 
+         List.map
+            (fun  t ->
+               let ty, _ = CicTypeChecker.type_of_aux' 
+                metasenv ~subst:[] context t CicUniv.oblivion_ugraph
+               in
+                t, ty)
+            restricted_univ
+       in
+         (* let automation_cache = AutomationCache.empty () in *) 
+       let automation_cache = 
+         let universe = Universe.empty in
+         let universe = 
+            Universe.index_list universe context t_ty
+         in
+           { automation_cache with AutomationCache.univ = universe }
+       in
+       let ct = 
+         if use_context then find_context_theorems context metasenv else t_ty
+       in
+       let automation_cache = 
+         add_list_to_tables metasenv subst automation_cache ct
+       in
     (* AutomationCache.pp_cache automation_cache; *)
-    automation_cache.AutomationCache.univ, 
-    automation_cache.AutomationCache.tables, 
-    cache_empty
+         automation_cache.AutomationCache.univ, 
+       automation_cache.AutomationCache.tables, 
+       cache_empty
 ;;
 
 let fill_hypothesis context metasenv subst term tables (universe:Universe.universe) cache auto fast = 
@@ -954,7 +957,7 @@ let demodulate_tac ~dbd ~params:(_,flags as params) ~automation_cache =
 (***************** applyS *******************)
 
 let apply_smart_aux 
- dbd automation_cache params proof goal newmeta' metasenv' subst
+ dbd automation_cache (params:auto_params) proof goal newmeta' metasenv' subst
   context term' ty termty goal_arity 
 = 
  let consthead,newmetasenv,arguments,_ =
@@ -1035,7 +1038,7 @@ let apply_smart_aux
         in
         match
           Saturation.solve_narrowing bag (proof'''',newmeta) active passive 
-            1 (*0 infinity*)
+            2 (*0 infinity*)
         with 
           | None, active, passive, bag -> 
               raise (ProofEngineTypes.Fail (lazy ("paramod fails")))
@@ -1631,17 +1634,26 @@ let try_candidate dbd
 
 let applicative_case dbd
   tables depth subst fake_proof goalno goalty metasenv context 
-  universe cache flags
+  signature universe cache flags
 = 
-  let goalty_aux = 
+  (* let goalty_aux = 
     match goalty with
     | Cic.Appl (hd::tl) -> 
         Cic.Appl (hd :: HExtlib.mk_list (Cic.Meta (0,[])) (List.length tl))
     | _ -> goalty
-  in
+  in *)
+  let goalty_aux = goalty in
   let candidates = 
     get_candidates flags.skip_trie_filtering universe cache goalty_aux
   in
+  (* if the goal is an equality we skip the congruence theorems 
+  let candidates =
+    if is_equational_case goalty flags 
+    then List.filter not_default_eq_term candidates 
+    else candidates 
+  in *)
+  let candidates = List.filter (only signature context metasenv) candidates 
+  in
   let tables, elems = 
     List.fold_left 
       (fun (tables,elems) cand ->
@@ -1662,7 +1674,7 @@ let try_smart_candidate dbd
 =
   let ppterm = ppterm context in
   try
-    let params = ([],[]) in
+    let params = (None,[]) in
     let automation_cache = { 
           AutomationCache.tables = tables ;
           AutomationCache.univ = Universe.empty; }
@@ -1712,7 +1724,6 @@ let smart_applicative_case dbd
     (lazy ("smart_candidates" ^ " = " ^ 
              (String.concat "\n" (List.map CicPp.ppterm smart_candidates)))) in
   debug_print debug_msg;
-(* we only filter the smart candidates since they could be too many *)
   let candidates = List.filter (only signature context metasenv) candidates in
   let smart_candidates = 
     List.filter (only signature context metasenv) smart_candidates 
@@ -1771,7 +1782,7 @@ let equational_and_applicative_case dbd
       else
         applicative_case dbd
           tables depth s fake_proof goalno 
-            gty m context universe cache flags
+            gty m context signature universe cache flags
     in
       elems@more_elems, tables, cache, flags            
   else
@@ -1782,7 +1793,7 @@ let equational_and_applicative_case dbd
            gty m context signature universe cache flags
       | None -> 
          applicative_case dbd tables depth s fake_proof goalno 
-           gty m context universe cache flags
+           gty m context signature universe cache flags
     in
       elems, tables, cache, flags  
 ;;
@@ -2119,6 +2130,21 @@ let auto_tac ~(dbd:HSql.dbd) ~params:(univ,params) ~automation_cache (proof, goa
   let _,metasenv,subst,_,_, _ = proof in
   let _,context,goalty = CicUtil.lookup_meta goal metasenv in
   let signature = MetadataQuery.signature_of metasenv goal in
+  let signature =
+    match univ with
+      | None -> signature
+      | Some l -> 
+         List.fold_left 
+           (fun set t ->
+               let ty, _ = 
+                CicTypeChecker.type_of_aux' metasenv context t 
+                  CicUniv.oblivion_ugraph
+              in
+                MetadataConstraints.UriManagerSet.union set 
+                  (MetadataConstraints.constants_of ty)
+           )
+           signature l
+  in
   let tables,cache =
     if flags.close_more then
       close_more