X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Ftactics%2FvariousTactics.ml;h=927552f0a60219c558dc35a38368541f90586ed7;hb=97c2d258a5c524eb5c4b85208899d80751a2c82f;hp=c1006032471a7d6fffc86959dcedca987c4a05bf;hpb=0575a1cb077087970f311b48f2e45dc4a01a6867;p=helm.git diff --git a/helm/ocaml/tactics/variousTactics.ml b/helm/ocaml/tactics/variousTactics.ml index c10060324..927552f0a 100644 --- a/helm/ocaml/tactics/variousTactics.ml +++ b/helm/ocaml/tactics/variousTactics.ml @@ -55,7 +55,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,39 +63,99 @@ let assumption_tac = (* ANCORA DA DEBUGGARE *) +exception UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly;; +exception TheSelectedTermsMustLiveInTheGoalContext exception AllSelectedTermsMustBeConvertible;; - -(* 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:[]) terms + ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) + pattern = let module PET = ProofEngineTypes in - let generalize_tac mk_fresh_name_callback terms status = + 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 typ,_ = - match terms with - [] -> assert false - | he::tl -> - (* We need to check that all the convertibility of all the terms *) - let u = List.fold_left ( (* TASSI: FIXME *) - fun u t -> - let b,u1 = CicReduction.are_convertible context he t u in - if not b then - raise AllSelectedTermsMustBeConvertible - else - u1) CicUniv.empty_ugraph tl in - (CicTypeChecker.type_of_aux' metasenv context he u) + 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 status = (uri,metasenv,pbo,pty),goal 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, metasenv, ugraph) + in + 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 - (T.thens + 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 ( + (* TASSI: FIXME *) + 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) ; + PET.apply_tactic + (T.thens ~start: (P.cut_tac (C.Prod( @@ -103,22 +163,14 @@ let generalize_tac typ, (ProofEngineReduction.replace_lifting_csc 1 ~equality:(==) - ~what:terms - ~with_what:(List.map (function _ -> C.Rel 1) terms) + ~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.Rel 1)) ; T.id_tac]) + ~continuations: + [(P.apply_tac ~term:(C.Appl [C.Rel 1; CicSubstitution.lift 1 term])) ; + T.id_tac]) status in - PET.mk_tactic (generalize_tac mk_fresh_name_callback terms) + PET.mk_tactic (generalize_tac mk_fresh_name_callback ~pattern) ;; - -let set_goal n = - ProofEngineTypes.mk_tactic - (fun (proof, goal) -> - let (_, metasenv, _, _) = proof in - if CicUtil.exists_meta n metasenv then - (proof, [n]) - else - raise (ProofEngineTypes.Fail ("no such meta: " ^ string_of_int n))) -