From: Andrea Asperti Date: Tue, 10 Mar 2009 16:07:03 +0000 (+0000) Subject: A version of applyS with bounded iterations of given_clause (10+10). X-Git-Tag: make_still_working~4167 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=59224cfec9e4037f4c2183c56625f06eb747fe9f;p=helm.git A version of applyS with bounded iterations of given_clause (10+10). Not sure it works on the full library. --- diff --git a/helm/software/components/tactics/auto.ml b/helm/software/components/tactics/auto.ml index 6b25982d3..1755fd08e 100644 --- a/helm/software/components/tactics/auto.ml +++ b/helm/software/components/tactics/auto.ml @@ -32,13 +32,113 @@ let debug_print s = if debug then prerr_endline (Lazy.force s);; +let mk_irl ctx = CicMkImplicit.identity_relocation_list_for_metavariable ctx;; +let ugraph = CicUniv.oblivion_ugraph;; +let typeof = CicTypeChecker.type_of_aux';; +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 +;; + +exception NotConvertible;; + +let check_proof_is_valid proof metasenv context goalty = + if debug then + begin + try + let ty,u = typeof metasenv context proof CicUniv.oblivion_ugraph in + let b,_ = CicReduction.are_convertible context ty goalty u in + if not b then raise NotConvertible else b + with _ -> + let names = + List.map (function None -> None | Some (x,_) -> Some x) context + in + debug_print (lazy ("PROOF:" ^ CicPp.pp proof names)); + (* debug_print (lazy ("PROOFTY:" ^ CicPp.pp ty names)); *) + debug_print (lazy ("GOAL:" ^ CicPp.pp goalty names)); + debug_print (lazy ("MENV:" ^ CicMetaSubst.ppmetasenv [] metasenv)); + false + end + else true +;; + +let assert_proof_is_valid proof metasenv context goalty = + assert (check_proof_is_valid proof metasenv context goalty) +;; + +let assert_subst_are_disjoint subst subst' = + if debug then + assert(List.for_all + (fun (i,_) -> List.for_all (fun (j,_) -> i<>j) subst') + subst) + else () +;; + +let split_goals_in_prop metasenv subst gl = + List.partition + (fun g -> + let _,context,ty = CicUtil.lookup_meta g metasenv in + try + let sort,u = typeof ~subst metasenv context ty ugraph in + is_propositional context sort + with + | CicTypeChecker.AssertFailure s + | CicTypeChecker.TypeCheckerFailure s -> + debug_print + (lazy ("NON TIPA" ^ ppterm context (CicMetaSubst.apply_subst subst ty))); + debug_print s; + false) + (* FIXME... they should type! *) + gl +;; +let split_goals_with_metas metasenv subst gl = + List.partition + (fun g -> + let _,context,ty = CicUtil.lookup_meta g metasenv in + let ty = CicMetaSubst.apply_subst subst ty in + CicUtil.is_meta_closed ty) + gl +;; + +let order_new_goals metasenv subst open_goals ppterm = + let prop,rest = split_goals_in_prop metasenv subst open_goals in + let closed_prop, open_prop = split_goals_with_metas metasenv subst prop in + let closed_type, open_type = split_goals_with_metas metasenv subst rest in + let open_goals = + (List.map (fun x -> x,P) (open_prop @ closed_prop)) + @ + (List.map (fun x -> x,T) (open_type @ closed_type)) + in + let tys = + List.map + (fun (i,sort) -> + let _,_,ty = CicUtil.lookup_meta i metasenv in i,ty,sort) open_goals + in + debug_print (lazy (" OPEN: "^ + String.concat "\n" + (List.map + (function + | (i,t,P) -> string_of_int i ^ ":"^ppterm t^ "Prop" + | (i,t,T) -> string_of_int i ^ ":"^ppterm t^ "Type") + tys))); + open_goals +;; + +let is_an_equational_goal = function + | Cic.Appl [Cic.MutInd(u,_,_);_;_;_] when LibraryObjects.is_eq_URI u -> true + | _ -> false +;; type auto_params = Cic.term list * (string * string) list @@ -48,6 +148,10 @@ let elems = ref [] ;; very naif version: it does not take dependencies properly into account *) let naif_closure ?(prefix_name="xxx_") t metasenv context = + let in_term t (i,_,_) = + List.exists (fun (j,_) -> j=i) (CicUtil.metas_of_term t) + in + let metasenv = List.filter (in_term t) metasenv in let metasenv = ProofEngineHelpers.sort_metasenv metasenv in let n = List.length metasenv in let what = List.map (fun (i,cc,ty) -> Cic.Meta(i,[])) metasenv in @@ -72,17 +176,17 @@ let naif_closure ?(prefix_name="xxx_") t metasenv context = CicSubstitution.lift n ty,t)) (n-1,body) metasenv in - t + t, List.length metasenv ;; let lambda_close ?prefix_name t menv ctx = - let t = naif_closure ?prefix_name t menv ctx in + let t, num_lambdas = naif_closure ?prefix_name t menv ctx in List.fold_left (fun (t,i) -> function | None -> CicSubstitution.subst (Cic.Implicit None) t,i (* delift *) | Some (name, Cic.Decl ty) -> Cic.Lambda (name, ty, t),i+1 | Some (name, Cic.Def (bo, ty)) -> Cic.LetIn (name, bo, ty, t),i+1) - (t,List.length menv) ctx + (t,num_lambdas) ctx ;; (* functions for retrieving theorems *) @@ -587,7 +691,8 @@ let universe_of_params metasenv context universe tl = let new_metasenv_and_unify_and_t dbd flags universe proof goal ?tables newmeta' metasenv' context term' ty termty goal_arity -= += + let ppterm = ppterm context in let (consthead,newmetasenv,arguments,_) = TermUtil.saturate_term newmeta' metasenv' context termty goal_arity in let term'' = @@ -623,13 +728,14 @@ let new_metasenv_and_unify_and_t (PrimitiveTactics.apply_tac term'') (proof''',goal) in - match - let (active, passive,bag), cache, maxmeta = - init_cache_and_tables ~dbd flags.use_library true true false universe + let (active, passive,bag), cache, maxm = + init_cache_and_tables ~dbd flags.use_library false (* was true *) + true false universe (proof'''',newmeta) in - Saturation.given_clause bag maxmeta (proof'''',newmeta) active passive - max_int max_int flags.timeout + match + Saturation.given_clause bag maxm (proof'''',newmeta) active passive + 10 10 flags.timeout with | None, _,_,_ -> raise (ProofEngineTypes.Fail (lazy ("FIXME: propaga le tabelle"))) @@ -637,6 +743,19 @@ let new_metasenv_and_unify_and_t proof''''', ProofEngineHelpers.compare_metasenvs ~oldmetasenv ~newmetasenv:(let _,m,_subst,_,_, _ = proof''''' in m), active, passive +(* + debug_print + (lazy + ("SUBSUMPTION SU: " ^ string_of_int newmeta ^ " " ^ ppterm goal_for_paramod)); + let res, maxmeta = + Saturation.all_subsumed bag maxm (proof'''',newmeta) active passive + in + if res = [] then + raise (ProofEngineTypes.Fail (lazy("BUM"))) + else let (_,proof''''',_) = List.hd res in + proof''''',ProofEngineHelpers.compare_metasenvs ~oldmetasenv + ~newmetasenv:(let _,m,_subst,_,_, _ = proof''''' in m), active, passive +*) ;; let rec count_prods context ty = @@ -702,107 +821,7 @@ let apply_smart (****************** AUTO ********************) -let mk_irl ctx = CicMkImplicit.identity_relocation_list_for_metavariable ctx;; -let ugraph = CicUniv.oblivion_ugraph;; -let typeof = CicTypeChecker.type_of_aux';; -let ppterm ctx t = - let names = List.map (function None -> None | Some (x,_) -> Some x) ctx in - CicPp.pp t names -;; -let is_in_prop context subst metasenv ty = - let sort,u = typeof ~subst metasenv context ty CicUniv.oblivion_ugraph in - is_propositional context sort -;; - -exception NotConvertible;; - -let check_proof_is_valid proof metasenv context goalty = - if debug then - begin - try - let ty,u = typeof metasenv context proof CicUniv.oblivion_ugraph in - let b,_ = CicReduction.are_convertible context ty goalty u in - if not b then raise NotConvertible else b - with _ -> - let names = - List.map (function None -> None | Some (x,_) -> Some x) context - in - debug_print (lazy ("PROOF:" ^ CicPp.pp proof names)); - (* debug_print (lazy ("PROOFTY:" ^ CicPp.pp ty names)); *) - debug_print (lazy ("GOAL:" ^ CicPp.pp goalty names)); - debug_print (lazy ("MENV:" ^ CicMetaSubst.ppmetasenv [] metasenv)); - false - end - else true -;; - -let assert_proof_is_valid proof metasenv context goalty = - assert (check_proof_is_valid proof metasenv context goalty) -;; - -let assert_subst_are_disjoint subst subst' = - if debug then - assert(List.for_all - (fun (i,_) -> List.for_all (fun (j,_) -> i<>j) subst') - subst) - else () -;; - -let split_goals_in_prop metasenv subst gl = - List.partition - (fun g -> - let _,context,ty = CicUtil.lookup_meta g metasenv in - try - let sort,u = typeof ~subst metasenv context ty ugraph in - is_propositional context sort - with - | CicTypeChecker.AssertFailure s - | CicTypeChecker.TypeCheckerFailure s -> - debug_print - (lazy ("NON TIPA" ^ ppterm context (CicMetaSubst.apply_subst subst ty))); - debug_print s; - false) - (* FIXME... they should type! *) - gl -;; - -let split_goals_with_metas metasenv subst gl = - List.partition - (fun g -> - let _,context,ty = CicUtil.lookup_meta g metasenv in - let ty = CicMetaSubst.apply_subst subst ty in - CicUtil.is_meta_closed ty) - gl -;; -let order_new_goals metasenv subst open_goals ppterm = - let prop,rest = split_goals_in_prop metasenv subst open_goals in - let closed_prop, open_prop = split_goals_with_metas metasenv subst prop in - let closed_type, open_type = split_goals_with_metas metasenv subst rest in - let open_goals = - (List.map (fun x -> x,P) (open_prop @ closed_prop)) - @ - (List.map (fun x -> x,T) (open_type @ closed_type)) - in - let tys = - List.map - (fun (i,sort) -> - let _,_,ty = CicUtil.lookup_meta i metasenv in i,ty,sort) open_goals - in - debug_print (lazy (" OPEN: "^ - String.concat "\n" - (List.map - (function - | (i,t,P) -> string_of_int i ^ ":"^ppterm t^ "Prop" - | (i,t,T) -> string_of_int i ^ ":"^ppterm t^ "Type") - tys))); - open_goals -;; - -let is_an_equational_goal = function - | Cic.Appl [Cic.MutInd(u,_,_);_;_;_] when LibraryObjects.is_eq_URI u -> true - | _ -> false -;; (* let prop = function (_,depth,P) -> depth < 9 | _ -> false;; @@ -1168,7 +1187,9 @@ let put_in_subst subst metasenv (goalno,_,_) canonical_ctx t ty = let entry = goalno, (canonical_ctx, t,ty) in assert_subst_are_disjoint subst [entry]; let subst = entry :: subst in + let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in + subst, metasenv ;; @@ -1373,8 +1394,18 @@ let prunable menv subst ty todo = (match calculate_goal_ty g variant menv with | None -> assert false | Some (_, gty') -> - if gty = gty' then - no_progress variant tl + if gty = gty' then no_progress variant tl +(* +(prerr_endline (string_of_int n); + prerr_endline (CicPp.ppterm gty); + prerr_endline (CicPp.ppterm gty'); + prerr_endline "---------- subst"; + prerr_endline (CicMetaSubst.ppsubst ~metasenv:menv subst); + prerr_endline "---------- variant"; + prerr_endline (CicMetaSubst.ppsubst ~metasenv:menv variant); + prerr_endline "---------- menv"; + prerr_endline (CicMetaSubst.ppmetasenv [] menv); + no_progress variant tl) *) else false)) | _::tl -> no_progress variant tl in @@ -1586,7 +1617,7 @@ let solutions,cache,maxm ;; -(* }}} ****************** AUTO ***************) +(******************* AUTO ***************) let auto flags metasenv tables universe cache context metasenv gl = let initial_time = Unix.gettimeofday() in @@ -1865,6 +1896,10 @@ let demodulate_tac ~dbd ~universe ~params:(univ, params) (proof,goal)= in let equalities = (Saturation.list_of_passive passive) in (* we demodulate using both actives passives *) + let env = metasenv,context,CicUniv.empty_ugraph in + debug_print (lazy ("PASSIVES:" ^ string_of_int(List.length equalities))); + List.iter (fun e -> debug_print (lazy (Equality.string_of_equality ~env e))) + equalities; let table = List.fold_left (fun tbl eq -> Indexing.index tbl eq)