X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Ftactics%2FvariousTactics.ml;h=bc7b52200fccd8b99961dd3a80f534b1cc849a4e;hb=782253ebe87375f52c07899c1501db5a665a457f;hp=226a8c87c831d29531078d1d56707ec3e9a919e0;hpb=df0606d3bcbc41272fcde2d013bbe0b1aadf98af;p=helm.git diff --git a/helm/ocaml/tactics/variousTactics.ml b/helm/ocaml/tactics/variousTactics.ml index 226a8c87c..bc7b52200 100644 --- a/helm/ocaml/tactics/variousTactics.ml +++ b/helm/ocaml/tactics/variousTactics.ml @@ -23,6 +23,8 @@ * http://cs.unibo.it/helm/. *) +(* $Id$ *) + (* TODO se ce n'e' piu' di una, prende la prima che trova... sarebbe meglio chiedere: find dovrebbe restituire una lista di hyp (?) da passare all'utonto con una @@ -55,7 +57,7 @@ let assumption_tac = if b then n else find (n+1) tl | _ -> find (n+1) tl ) - | [] -> raise (PET.Fail "Assumption: No such assumption") + | [] -> raise (PET.Fail (lazy "Assumption: No such assumption")) in PET.apply_tactic (PT.apply_tac ~term:(C.Rel (find 1 context))) status in PET.mk_tactic assumption_tac @@ -63,71 +65,127 @@ let assumption_tac = (* ANCORA DA DEBUGGARE *) +exception UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly;; +exception TheSelectedTermsMustLiveInTheGoalContext exception AllSelectedTermsMustBeConvertible;; -exception CannotGeneralizeInHypotheses;; - -(* serve una funzione che cerchi nel ty dal basso a partire da term, i lambda -e li aggiunga nel context, poi si conta la lunghezza di questo nuovo -contesto e si lifta di tot... COSA SIGNIFICA TUTTO CIO'?????? *) +exception GeneralizationInHypothesesNotImplementedYet;; let generalize_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) - ~term pattern + pattern = let module PET = ProofEngineTypes in - let generalize_tac mk_fresh_name_callback ~term (hyps_pat,concl_pat) status = - if hyps_pat <> [] then raise CannotGeneralizeInHypotheses ; + let generalize_tac mk_fresh_name_callback + ~pattern:(term,hyps_pat,concl_pat) status + = + if hyps_pat <> [] then raise GeneralizationInHypothesesNotImplementedYet; let (proof, goal) = status in let module C = Cic in let module P = PrimitiveTactics in let module T = Tacticals in - let _,metasenv,_,_ = proof in - let _,context,ty = CicUtil.lookup_meta goal metasenv in - let terms = - let path = - match concl_pat with - None -> Cic.Implicit (Some `Hole) - | Some path -> path in - let roots = ProofEngineHelpers.select ~term:ty ~pattern:path in - List.fold_left - (fun acc (i, r) -> - ProofEngineHelpers.find_subterms - ~eq:ProofEngineReduction.alpha_equivalence ~wanted:term r @ acc - ) [] roots + let uri,metasenv,pbo,pty = proof in + let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in + let subst,metasenv,u,selected_hyps,terms_with_context = + ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph + ~conjecture ~pattern in + let context = CicMetaSubst.apply_subst_context subst context in + let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in + let pbo = CicMetaSubst.apply_subst subst pbo in + let pty = CicMetaSubst.apply_subst subst pty in + let term = + match term with + None -> None + | Some term -> + Some (fun context metasenv ugraph -> + let term, metasenv, ugraph = term context metasenv ugraph in + CicMetaSubst.apply_subst subst term, + CicMetaSubst.apply_subst_metasenv subst metasenv, + ugraph) in - let typ = - let typ,u = - CicTypeChecker.type_of_aux' metasenv context term CicUniv.empty_ugraph in - (* We need to check that all the convertibility of all the terms *) - ignore ( - (* TASSI: FIXME *) - List.fold_left - (fun u t -> - let b,u1 = CicReduction.are_convertible context term t u in - if not b then - raise AllSelectedTermsMustBeConvertible - else - u1 - ) u terms) ; - typ + let u,typ,term, metasenv' = + let context_of_t, (t, metasenv, u) = + match terms_with_context, term with + [], None -> + raise + UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly + | [], Some t -> context, t context metasenv u + | (context_of_t, _)::_, Some t -> + context_of_t, t context_of_t metasenv u + | (context_of_t, t)::_, None -> context_of_t, (t, metasenv, u) in - PET.apply_tactic + let t,subst,metasenv' = + try + CicMetaSubst.delift_rels [] metasenv + (List.length context_of_t - List.length context) t + with + CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> + raise TheSelectedTermsMustLiveInTheGoalContext + in + (*CSC: I am not sure about the following two assertions; + maybe I need to propagate the new subst and metasenv *) + assert (subst = []); + assert (metasenv' = metasenv); + let typ,u = CicTypeChecker.type_of_aux' ~subst metasenv context t u in + u,typ,t,metasenv + in + (* We need to check: + 1. whether they live in the context of the goal; + if they do they are also well-typed since they are closed subterms + of a well-typed term in the well-typed context of the well-typed + term + 2. whether they are convertible + *) + ignore ( + List.fold_left + (fun u (context_of_t,t) -> + (* 1 *) + let t,subst,metasenv'' = + try + CicMetaSubst.delift_rels [] metasenv' + (List.length context_of_t - List.length context) t + with + CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> + raise TheSelectedTermsMustLiveInTheGoalContext in + (*CSC: I am not sure about the following two assertions; + maybe I need to propagate the new subst and metasenv *) + assert (subst = []); + assert (metasenv'' = metasenv'); + (* 2 *) + let b,u1 = CicReduction.are_convertible ~subst context term t u in + if not b then + raise AllSelectedTermsMustBeConvertible + else + u1 + ) u terms_with_context) ; + let status = (uri,metasenv',pbo,pty),goal in + let proof,goals = + PET.apply_tactic (T.thens - ~start: - (P.cut_tac - (C.Prod( - (mk_fresh_name_callback metasenv context C.Anonymous ~typ:typ), - typ, - (ProofEngineReduction.replace_lifting_csc 1 - ~equality:(==) - ~what:terms - ~with_what:(List.map (function _ -> C.Rel 1) terms) - ~where:ty) - ))) - ~continuations: - [(P.apply_tac ~term:(C.Appl [C.Rel 1; CicSubstitution.lift 1 term])) ; - T.id_tac]) - status + ~start: + (P.cut_tac + (C.Prod( + (mk_fresh_name_callback metasenv context C.Anonymous ~typ:typ), + typ, + (ProofEngineReduction.replace_lifting_csc 1 + ~equality:(==) + ~what:(List.map snd terms_with_context) + ~with_what:(List.map (function _ -> C.Rel 1) terms_with_context) + ~where:ty) + ))) + ~continuations: + [(P.apply_tac ~term:(C.Appl [C.Rel 1; CicSubstitution.lift 1 term])) ; + T.id_tac]) + status + in + let _,metasenv'',_,_ = proof in + (* CSC: the following is just a bad approximation since a meta + can be closed and then re-opened! *) + (proof, + goals @ + (List.filter + (fun j -> List.exists (fun (i,_,_) -> i = j) metasenv'') + (ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv + ~newmetasenv:metasenv'))) in - PET.mk_tactic (generalize_tac mk_fresh_name_callback ~term pattern) + PET.mk_tactic (generalize_tac mk_fresh_name_callback ~pattern) ;;