X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=inline;f=helm%2Fsoftware%2Fcomponents%2Ftactics%2Fauto.ml;h=a01ca86913eedfbe9789997c54d3e9c0576bfb24;hb=b4f6b1a39b59e923527f5c17d8fdd0fa1e13e1bf;hp=e7c11d43dfc9371613085d3ff2081562bdcccbb6;hpb=8e76ac2823de8cffc0b5f75b36264f86e3d0b52d;p=helm.git diff --git a/helm/software/components/tactics/auto.ml b/helm/software/components/tactics/auto.ml index e7c11d43d..a01ca8691 100644 --- a/helm/software/components/tactics/auto.ml +++ b/helm/software/components/tactics/auto.ml @@ -1,4 +1,5 @@ (* Copyright (C) 2002, HELM Team. + * * This file is part of HELM, an Hypertextual, Electronic * Library of Mathematics, developed at the Computer Science @@ -26,18 +27,118 @@ open AutoTypes;; open AutoCache;; -let debug = true;; +let debug = false;; 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 @@ -47,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 @@ -71,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 *) @@ -182,13 +287,17 @@ let only signature context metasenv t = in let consts = MetadataConstraints.constants_of ty in let b = MetadataConstraints.UriManagerSet.subset consts signature in - if b then (prerr_endline ("keeping " ^ (CicPp.ppterm t)); b) +(* if b then (prerr_endline ("keeping " ^ (CicPp.ppterm t)); b) *) + if b then b else let ty' = unfold context ty in let consts' = MetadataConstraints.constants_of ty' in let b = MetadataConstraints.UriManagerSet.subset consts' signature in +(* if not b then prerr_endline ("filtering " ^ (CicPp.ppterm t)) - else prerr_endline ("keeping " ^ (CicPp.ppterm t)); b + else prerr_endline ("keeping " ^ (CicPp.ppterm t)); +*) + b with | CicTypeChecker.TypeCheckerFailure _ -> assert false | ProofEngineTypes.Fail _ -> false (* unfold may fail *) @@ -580,9 +689,10 @@ let universe_of_params metasenv context universe tl = (***************** applyS *******************) let new_metasenv_and_unify_and_t - dbd flags universe proof goal ?tables newmeta' metasenv' + dbd flags automation_cache 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'' = @@ -618,13 +728,16 @@ 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 + (* XXX automation_cache *) + let universe = automation_cache.AutomationCache.univ in + 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 + 20 10 flags.timeout with | None, _,_,_ -> raise (ProofEngineTypes.Fail (lazy ("FIXME: propaga le tabelle"))) @@ -632,6 +745,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 = @@ -640,7 +766,7 @@ let rec count_prods context ty = | _ -> 0 let apply_smart - ~dbd ~term ~subst ~universe ?tables ~params:(univ,params) (proof, goal) + ~dbd ~term ~subst ~automation_cache ?tables ~params:(univ,params) (proof, goal) = let module T = CicTypeChecker in let module R = CicReduction in @@ -648,7 +774,11 @@ let apply_smart let (_,metasenv,_subst,_,_, _) = proof in let metano,context,ty = CicUtil.lookup_meta goal metasenv in let flags = flags_of_params params ~for_applyS:true () in + (* XXX automation_cache *) + let universe = automation_cache.AutomationCache.univ in let universe = universe_of_params metasenv context universe univ in + let automation_cache = { automation_cache with AutomationCache.univ = universe } in + let newmeta = CicMkImplicit.new_meta metasenv subst in let exp_named_subst_diff,newmeta',newmetasenvfragment,term' = match term with @@ -689,7 +819,7 @@ let apply_smart let termty = CicSubstitution.subst_vars exp_named_subst_diff termty in let goal_arity = count_prods context ty in let proof, gl, active, passive = - new_metasenv_and_unify_and_t dbd flags universe proof goal ?tables + new_metasenv_and_unify_and_t dbd flags automation_cache proof goal ?tables newmeta' metasenv' context term' ty termty goal_arity in proof, gl, active, passive @@ -697,107 +827,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;; @@ -1163,7 +1193,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 ;; @@ -1368,8 +1400,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 @@ -1581,7 +1623,7 @@ let solutions,cache,maxm ;; -(* }}} ****************** AUTO ***************) +(******************* AUTO ***************) let auto flags metasenv tables universe cache context metasenv gl = let initial_time = Unix.gettimeofday() in @@ -1599,12 +1641,12 @@ let auto flags metasenv tables universe cache context metasenv gl = None,cache ;; -let applyS_tac ~dbd ~term ~params ~universe = +let applyS_tac ~dbd ~term ~params ~automation_cache = ProofEngineTypes.mk_tactic (fun status -> try let proof, gl,_,_ = - apply_smart ~dbd ~term ~subst:[] ~params ~universe status + apply_smart ~dbd ~term ~subst:[] ~params ~automation_cache status in proof, gl with @@ -1612,10 +1654,12 @@ let applyS_tac ~dbd ~term ~params ~universe = | CicTypeChecker.TypeCheckerFailure msg -> raise (ProofEngineTypes.Fail msg)) -let auto_tac ~(dbd:HSql.dbd) ~params:(univ,params) ~universe (proof, goal) = +let auto_tac ~(dbd:HSql.dbd) ~params:(univ,params) ~automation_cache (proof, goal) = let _,metasenv,_subst,_,_, _ = proof in let _,context,goalty = CicUtil.lookup_meta goal metasenv in let flags = flags_of_params params () in + (* XXX automation_cache *) + let universe = automation_cache.AutomationCache.univ in let universe = universe_of_params metasenv context universe univ in let use_library = flags.use_library in let tables,cache,newmeta = @@ -1653,8 +1697,8 @@ let auto_tac ~(dbd:HSql.dbd) ~params:(univ,params) ~universe (proof, goal) = raise (ProofEngineTypes.Fail (lazy "Auto gave up")) ;; -let auto_tac ~dbd ~params ~universe = - ProofEngineTypes.mk_tactic (auto_tac ~params ~dbd ~universe);; +let auto_tac ~dbd ~params ~automation_cache = + ProofEngineTypes.mk_tactic (auto_tac ~params ~dbd ~automation_cache);; let eq_of_goal = function | Cic.Appl [Cic.MutInd(uri,0,_);_;_;_] when LibraryObjects.is_eq_URI uri -> @@ -1664,10 +1708,12 @@ let eq_of_goal = function (* performs steps of rewrite with the universe, obtaining if possible * a trivial goal *) -let solve_rewrite_tac ~universe ~params:(univ,params) (proof,goal as status)= +let solve_rewrite_tac ~automation_cache ~params:(univ,params) (proof,goal as status)= let _,metasenv,_subst,_,_,_ = proof in let _,context,ty = CicUtil.lookup_meta goal metasenv in let steps = int_of_string (string params "steps" "1") in + (* XXX automation_cache *) + let universe = automation_cache.AutomationCache.univ in let universe = universe_of_params metasenv context universe univ in let eq_uri = eq_of_goal ty in let (active,passive,bag), cache, maxm = @@ -1700,8 +1746,8 @@ let solve_rewrite_tac ~universe ~params:(univ,params) (proof,goal as status)= (ProofEngineTypes.Fail (lazy ("Unable to solve with " ^ string_of_int steps ^ " demodulations"))) ;; -let solve_rewrite_tac ~params ~universe () = - ProofEngineTypes.mk_tactic (solve_rewrite_tac ~universe ~params) +let solve_rewrite_tac ~params ~automation_cache () = + ProofEngineTypes.mk_tactic (solve_rewrite_tac ~automation_cache ~params) ;; (* Demodulate thorem *) @@ -1760,7 +1806,7 @@ let is_subsumed univ context ty = ) None candidates ;; -let demodulate_theorem ~universe uri = +let demodulate_theorem ~automation_cache uri = let eq_uri = match LibraryObjects.eq_URI () with | Some (uri) -> uri @@ -1783,6 +1829,8 @@ let demodulate_theorem ~universe uri = MetadataQuery.close_with_types set [] context in (* retrieve equations from the universe universe *) + (* XXX automation_cache *) + let universe = automation_cache.AutomationCache.univ in let equations = retrieve_equations true signature universe AutoCache.cache_empty context [] in @@ -1843,9 +1891,11 @@ let demodulate_theorem ~universe uri = (* NEW DEMODULATE *) -let demodulate_tac ~dbd ~universe ~params:(univ, params) (proof,goal)= +let demodulate_tac ~dbd ~automation_cache ~params:(univ, params) (proof,goal)= let curi,metasenv,_subst,pbo,pty, attrs = proof in let metano,context,ty = CicUtil.lookup_meta goal metasenv in + (* XXX automation_cache *) + let universe = automation_cache.AutomationCache.univ in let universe = universe_of_params metasenv context universe univ in let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in let initgoal = [], metasenv, ty in @@ -1860,6 +1910,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) @@ -1893,8 +1947,8 @@ let demodulate_tac ~dbd ~universe ~params:(univ, params) (proof,goal)= ~pattern:(ProofEngineTypes.conclusion_pattern None)) initialstatus*) ;; -let demodulate_tac ~dbd ~params ~universe = - ProofEngineTypes.mk_tactic (demodulate_tac ~dbd ~params ~universe);; +let demodulate_tac ~dbd ~params ~automation_cache = + ProofEngineTypes.mk_tactic (demodulate_tac ~dbd ~params ~automation_cache);; let pp_proofterm = Equality.pp_proofterm;;