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);;
let vcompare (_,v1) (_,v2) =
Pervasives.compare (relevance v1) (relevance v2) in
let l = List.sort vcompare l in
+ let short_name r =
+ Filename.chop_extension
+ (Filename.basename (NReference.string_of_reference r))
+ in
let vstring (a,v)=
- NotationPp.pp_term status (Ast.NCic (NCic.Const a)) ^ ": rel = " ^
+ short_name a ^ ": rel = " ^
(string_of_float (relevance v)) ^
"; uses = " ^ (string_of_int !(v.uses)) ^
"; nom = " ^ (string_of_int !(v.nominations)) in
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)
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)));
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
;;
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
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 _
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
;;
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
;;
(*
(* 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
;;
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
| 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 =
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
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))
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
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
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
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
(* 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
exception Found
;;
-
(* gty is supposed to be meta-closed *)
let is_subsumed depth filter_depth status gty cache =
if cache=[] then false else (
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));
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
| 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)
fast_eq_check_tac ~params
else auto_tac ~params ?trace_ref
;;
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
projects / helm.git / blobdiff