X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=matita%2Fcomponents%2Fng_tactics%2FnnAuto.ml;h=1937229af366726d641bd7bcc13a43d0a9085aa8;hb=4b4d24e46ac80c9b035b6c23944d851f9f0ec179;hp=32573639b350a11d591e23cecdd5bf42003a433c;hpb=4db1d6f4484eb6615bffc045078b0aded277d45a;p=helm.git diff --git a/matita/components/ng_tactics/nnAuto.ml b/matita/components/ng_tactics/nnAuto.ml index 32573639b..1937229af 100644 --- a/matita/components/ng_tactics/nnAuto.ml +++ b/matita/components/ng_tactics/nnAuto.ml @@ -26,9 +26,9 @@ let app_counter = ref 0 module RHT = struct type t = NReference.reference - let equal = (==) - let compare = Pervasives.compare - let hash = Hashtbl.hash + let equal = NReference.eq + let compare = NReference.compare + let hash = NReference.hash end;; module RefHash = Hashtbl.Make(RHT);; @@ -145,7 +145,7 @@ let is_a_fact_obj s uri = let is_a_fact_ast status subst metasenv ctx cand = noprint ~depth:0 (lazy ("checking facts " ^ NotationPp.pp_term status cand)); - let status, t = disambiguate status ctx ("",0,cand) None in + let status, t = disambiguate status ctx ("",0,cand) `XTNone in let status,t = term_of_cic_term status t ctx in let ty = NCicTypeChecker.typeof status subst metasenv ctx t in is_a_fact status (mk_cic_term ctx ty) @@ -247,7 +247,7 @@ let solve f status eq_cache goal = NCicUnification.unify status metasenv subst ctx gty pty *) NCicRefiner.typeof (status#set_coerc_db NCicCoercion.empty_db) - metasenv subst ctx pt (Some gty) + metasenv subst ctx pt (`XTSome gty) in noprint (lazy (Printf.sprintf "Refined in %fs" (Unix.gettimeofday() -. stamp))); @@ -267,6 +267,7 @@ let solve f status eq_cache goal = Lazy.force msg ^ "\n in the environment\n" ^ status#ppmetasenv subst metasenv)); None + | Sys.Break as e -> raise e | _ -> None in HExtlib.filter_map build_status @@ -292,10 +293,11 @@ let auto_eq_check eq_cache status = ;; let index_local_equations eq_cache status = + noprint (lazy "indexing equations"); let open_goals = head_goals status#stack in let open_goal = List.hd open_goals in - debug_print (lazy ("indexing equations for " ^ string_of_int open_goal)); let ngty = get_goalty status open_goal in + let _,_,metasenv,subst,_ = status#obj in let ctx = apply_subst_context ~fix_projections:true status (ctx_of ngty) in let c = ref 0 in List.fold_left @@ -303,12 +305,12 @@ let index_local_equations eq_cache status = c:= !c+1; let t = NCic.Rel !c in try - let ty = NCicTypeChecker.typeof status [] [] ctx t in + let ty = NCicTypeChecker.typeof status subst metasenv ctx t in if is_a_fact status (mk_cic_term ctx ty) then - (debug_print(lazy("eq indexing " ^ (status#ppterm ctx [] [] ty))); - NCicParamod.forward_infer_step eq_cache t ty) + (debug_print(lazy("eq indexing " ^ (status#ppterm ctx subst metasenv ty))); + NCicParamod.forward_infer_step status metasenv subst ctx eq_cache t ty) else - (noprint (lazy ("not a fact: " ^ (status#ppterm ctx [] [] ty))); + (noprint (lazy ("not a fact: " ^ (status#ppterm ctx subst metasenv ty))); eq_cache) with | NCicTypeChecker.TypeCheckerFailure _ @@ -316,6 +318,44 @@ let index_local_equations eq_cache status = eq_cache ctx ;; +let index_local_equations2 eq_cache status open_goal lemmas nohyps = + noprint (lazy "indexing equations"); + let eq_cache,lemmas = + match lemmas with + None -> eq_cache,[] + | Some l -> NCicParamod.empty_state,l + in + let ngty = get_goalty status open_goal in + let _,_,metasenv,subst,_ = status#obj in + let ctx = apply_subst_context ~fix_projections:true status (ctx_of ngty) in + let status,lemmas = + List.fold_left + (fun (status,lemmas) l -> + let status,l = NTacStatus.disambiguate status ctx l `XTNone in + let status,l = NTacStatus.term_of_cic_term status l ctx in + status,l::lemmas) + (status,[]) lemmas in + let local_equations = + if nohyps then [] else + List.map (fun i -> NCic.Rel (i + 1)) + (HExtlib.list_seq 1 (List.length ctx)) in + let lemmas = lemmas @ local_equations in + List.fold_left + (fun eq_cache t -> + try + let ty = NCicTypeChecker.typeof status subst metasenv ctx t in + if is_a_fact status (mk_cic_term ctx ty) then + (debug_print(lazy("eq indexing " ^ (status#ppterm ctx subst metasenv ty))); + NCicParamod.forward_infer_step status metasenv subst ctx eq_cache t ty) + else + (noprint (lazy ("not a fact: " ^ (status#ppterm ctx subst metasenv ty))); + eq_cache) + with + | NCicTypeChecker.TypeCheckerFailure _ + | NCicTypeChecker.AssertFailure _ -> eq_cache) + eq_cache lemmas +;; + let fast_eq_check_tac ~params s = let unit_eq = index_local_equations s#eq_cache s in dist_fast_eq_check unit_eq s @@ -339,8 +379,11 @@ let demod eq_cache status goal = ;; let demod_tac ~params s = - let unit_eq = index_local_equations s#eq_cache s in - NTactics.distribute_tac (demod unit_eq) s + let unit_eq s i = + index_local_equations2 s#eq_cache s i (fst params) + (List.mem_assoc "nohyps" (snd params)) + in + NTactics.distribute_tac (fun s i -> demod (unit_eq s i) s i) s ;; (* @@ -435,7 +478,9 @@ let close_metasenv status metasenv subst = (* prerr_endline (status#ppterm ctx [] [] iterm); *) let s_entry = i, ([], ctx, iterm, ty) in s_entry::subst,okind::objs - with _ -> assert false) + with + Sys.Break as e -> raise e + | _ -> assert false) (subst,[]) metasenv ;; @@ -545,7 +590,7 @@ let smart_apply t unit_eq status g = let n,h,metasenv,subst,o = status#obj in let gname, ctx, gty = List.assoc g metasenv in (* let ggty = mk_cic_term context gty in *) - let status, t = disambiguate status ctx t None in + let status, t = disambiguate status ctx t `XTNone in let status,t = term_of_cic_term status t ctx in let _,_,metasenv,subst,_ = status#obj in let ty = NCicTypeChecker.typeof status subst metasenv ctx t in @@ -587,6 +632,10 @@ let smart_apply t unit_eq status g = | NCicEnvironment.ObjectNotFound s as e -> raise (Error (lazy "eq_coerc non yet defined",Some e)) | Error _ as e -> debug_print (lazy "error"); raise e +(* FG: for now we catch TypeCheckerFailure; to be understood *) + | NCicTypeChecker.TypeCheckerFailure _ -> + debug_print (lazy "TypeCheckerFailure"); + raise (Error (lazy "no proof found",None)) ;; let compare_statuses ~past ~present = @@ -846,7 +895,6 @@ type flags = { maxwidth : int; maxsize : int; maxdepth : int; - timeout : float; } type cache = @@ -929,7 +977,7 @@ let openg_no status = List.length (head_goals status#stack) let sort_candidates status ctx candidates = let _,_,metasenv,subst,_ = status#obj in let branch cand = - let status,ct = disambiguate status ctx ("",0,cand) None in + let status,ct = disambiguate status ctx ("",0,cand) `XTNone in let status,t = term_of_cic_term status ct ctx in let ty = NCicTypeChecker.typeof status subst metasenv ctx t in let res = branch status (mk_cic_term ctx ty) in @@ -1018,7 +1066,7 @@ let perforate_small status subst metasenv context t = let rec aux = function | NCic.Appl (hd::tl) -> let map t = - let s = sort_of status subst metasenv context t in + let s = sort_of status subst metasenv context t in match s with | NCic.Sort(NCic.Type [`Type,u]) when u=type0 -> NCic.Meta (0,(0,NCic.Irl 0)) @@ -1039,7 +1087,7 @@ let get_cands retrieve_for diff empty gty weak_gty = cands, diff more_cands cands ;; -let get_candidates ?(smart=true) depth flags status cache signature gty = +let get_candidates ?(smart=true) ~pfailed depth flags status cache signature gty = let universe = status#auto_cache in let _,_,metasenv,subst,_ = status#obj in let context = ctx_of gty in @@ -1064,7 +1112,7 @@ let get_candidates ?(smart=true) depth flags status cache signature gty = let raw_weak = perforate_small status subst metasenv context raw_gty in let weak = mk_cic_term context raw_weak in - debug_print ~depth (lazy ("weak_gty:" ^ NTacStatus.ppterm status weak)); + noprint ~depth (lazy ("weak_gty:" ^ NTacStatus.ppterm status weak)); Some raw_weak, Some (weak) | _ -> None,None else None,None @@ -1109,10 +1157,11 @@ let get_candidates ?(smart=true) depth flags status cache signature gty = let candidates_facts,candidates_other = let gl1,gl2 = List.partition test global_cands in let ll1,ll2 = List.partition test local_cands in - (* if the goal is an equation we avoid to apply unit equalities, - since superposition should take care of them; refl is an + (* if the goal is an equation and paramodulation did not fail + we avoid to apply unit equalities; refl is an exception since it prompts for convertibility *) - let l1 = if is_eq then [Ast.Ident("refl",None)] else gl1@ll1 in + let l1 = if is_eq && (not pfailed) + then [Ast.Ident("refl",None)] else gl1@ll1 in let l2 = (* if smart given candidates are applied in smart mode *) if by && smart then ll2 @@ -1140,7 +1189,7 @@ let get_candidates ?(smart=true) depth flags status cache signature gty = sort_candidates status context (smart_candidates_other) ;; -let applicative_case depth signature status flags gty cache = +let applicative_case ~pfailed depth signature status flags gty cache = app_counter:= !app_counter+1; let _,_,metasenv,subst,_ = status#obj in let context = ctx_of gty in @@ -1156,7 +1205,7 @@ let applicative_case depth signature status flags gty cache = (* new *) let candidates_facts, smart_candidates_facts, candidates_other, smart_candidates_other = - get_candidates ~smart:true depth + get_candidates ~smart:true ~pfailed depth flags status tcache signature gty in let sm = if is_eq || is_prod then 0 else 2 in @@ -1190,7 +1239,6 @@ let applicative_case depth signature status flags gty cache = exception Found ;; - (* gty is supposed to be meta-closed *) let is_subsumed depth filter_depth status gty cache = if cache=[] then false else ( @@ -1361,7 +1409,7 @@ let is_meta status gty = let do_something signature flags status g depth gty cache = (* if the goal is meta we close it with I:True. This should work - thnaks to the toplogical sorting of goals. *) + thanks to the toplogical sorting of goals. *) if is_meta status gty then let t = Ast.Ident("I",None) in debug_print (lazy ("using default term" ^ (NotationPp.pp_term status) t)); @@ -1384,7 +1432,7 @@ let do_something signature flags status g depth gty cache = in let l2 = if ((l1 <> []) && flags.last) then [] else - applicative_case depth signature status flags gty cache + applicative_case ~pfailed:(l1=[]) depth signature status flags gty cache in (* statistics *) List.iter @@ -1766,7 +1814,8 @@ let auto_tac ~params:(univ,flags) ?(trace_ref=ref []) status = | None -> None | Some l -> let to_Ast t = - let status, res = disambiguate status [] t None in +(* FG: `XTSort here? *) + let status, res = disambiguate status [] t `XTNone in let _,res = term_of_cic_term status res (ctx_of res) in Ast.NCic res in Some (List.map to_Ast l) @@ -1783,7 +1832,6 @@ let auto_tac ~params:(univ,flags) ?(trace_ref=ref []) status = maxwidth = width; maxsize = size; maxdepth = depth; - timeout = Unix.gettimeofday() +. 3000.; do_types = false; } in let initial_time = Unix.gettimeofday() in @@ -1837,23 +1885,3 @@ let auto_tac ~params:(_,flags as params) ?trace_ref = fast_eq_check_tac ~params else auto_tac ~params ?trace_ref ;; - - - - - - - - - - - - - - - - - - - -