X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Ftactics%2FvariousTactics.ml;h=e2003f48d4ab1b2b437393245b5b3aa8d9fa4476;hb=249d79bebff886846fbab65cc079623d90684baf;hp=28acd57ec250400b5144b5098999b68cca72e412;hpb=7b922ad1f9832c1edb3acea8f0c910fa2c0c20e5;p=helm.git diff --git a/helm/ocaml/tactics/variousTactics.ml b/helm/ocaml/tactics/variousTactics.ml index 28acd57ec..e2003f48d 100644 --- a/helm/ocaml/tactics/variousTactics.ml +++ b/helm/ocaml/tactics/variousTactics.ml @@ -28,71 +28,118 @@ chiedere: find dovrebbe restituire una lista di hyp (?) da passare all'utonto con una funzione di callback che restituisce la (sola) hyp da applicare *) -let assumption_tac ~status:((proof,goal) as status) = +let assumption_tac = + let module PET = ProofEngineTypes in + let assumption_tac status = + let (proof, goal) = status in let module C = Cic in let module R = CicReduction in let module S = CicSubstitution in - let _,metasenv,_,_ = proof in - let _,context,ty = CicUtil.lookup_meta goal metasenv in - let rec find n = function - hd::tl -> - (match hd with + let module PT = PrimitiveTactics in + let _,metasenv,_,_ = proof in + let _,context,ty = CicUtil.lookup_meta goal metasenv in + let rec find n = function + hd::tl -> + (match hd with (Some (_, C.Decl t)) when - (R.are_convertible context (S.lift n t) ty) -> n + fst (R.are_convertible context (S.lift n t) ty + CicUniv.empty_ugraph) -> n | (Some (_, C.Def (_,Some ty'))) when - (R.are_convertible context ty' ty) -> n - | (Some (_, C.Def (t,None))) when - (R.are_convertible context - (CicTypeChecker.type_of_aux' metasenv context (S.lift n t)) ty) -> n + fst (R.are_convertible context (S.lift n ty') ty + CicUniv.empty_ugraph) -> n + | (Some (_, C.Def (t,None))) -> + let ty_t, u = (* TASSI: FIXME *) + CicTypeChecker.type_of_aux' metasenv context (S.lift n t) + CicUniv.empty_ugraph in + let b,_ = R.are_convertible context ty_t ty u in + if b then n else find (n+1) tl | _ -> find (n+1) tl ) - | [] -> raise (ProofEngineTypes.Fail "Assumption: No such assumption") - in PrimitiveTactics.apply_tac ~status ~term:(C.Rel (find 1 context)) + | [] -> raise (PET.Fail "Assumption: No such assumption") + in PET.apply_tactic (PT.apply_tac ~term:(C.Rel (find 1 context))) status + in + PET.mk_tactic assumption_tac ;; (* ANCORA DA DEBUGGARE *) +exception UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly;; +exception TheSelectedTermsMustLiveInTheGoalContext exception AllSelectedTermsMustBeConvertible;; +exception GeneralizationInHypothesesNotImplementedYet;; -(* 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'?????? *) - -let generalize_tac - ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name) - terms ~status:((proof,goal) as status) -= - 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 *) - List.iter - (function t -> - if not (CicReduction.are_convertible context he t) then - raise AllSelectedTermsMustBeConvertible - ) tl ; - (CicTypeChecker.type_of_aux' metasenv context he) - in - T.thens - ~start: - (P.cut_tac - (C.Prod( - (mk_fresh_name_callback context C.Anonymous 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.Rel 1)) ; T.id_tac] - ~status +let generalize_tac + ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) + pattern + = + let module PET = ProofEngineTypes in + 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) as conjecture = CicUtil.lookup_meta goal metasenv in + let selected_hyps,terms_with_context = + ProofEngineHelpers.select ~metasenv ~conjecture ~pattern in + let typ,term = + match terms_with_context, term with + [], None -> + raise UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly + | _, Some term + | (_,term)::_, None -> + fst + (CicTypeChecker.type_of_aux' metasenv context term + CicUniv.empty_ugraph), + term 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 *) + begin + try + ignore + (CicMetaSubst.delift_rels [] metasenv + (List.length context_of_t - List.length context) t) + with + CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable -> + raise TheSelectedTermsMustLiveInTheGoalContext + end; + (* 2 *) + let b,u1 = CicReduction.are_convertible context term t u in + if not b then + raise AllSelectedTermsMustBeConvertible + else + u1 + ) CicUniv.empty_ugraph terms_with_context) ; + 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:(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 + PET.mk_tactic (generalize_tac mk_fresh_name_callback ~pattern) ;; - -