diff --git a/erasure/theories/EArities.v b/erasure/theories/EArities.v index f687356d5..e9c63034f 100644 --- a/erasure/theories/EArities.v +++ b/erasure/theories/EArities.v @@ -8,7 +8,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICWeakeningEnv PCUICWeakeningEnvTyp PCUICWellScopedCumulativity PCUICContextConversion PCUICConversion PCUICCanonicity - PCUICSpine PCUICInductives PCUICInductiveInversion PCUICConfluence + PCUICSpine PCUICInductives PCUICInductiveInversion PCUICConfluence PCUICArities PCUICPrincipality. From MetaCoq.Erasure Require Import Extract. @@ -60,7 +60,7 @@ Lemma isArity_ind_type (Σ : global_env_ext) mind ind idecl : declared_inductive (fst Σ) ind mind idecl -> isArity (ind_type idecl). Proof. - intros. + intros. eapply (declared_inductive_inv weaken_env_prop_typing) in H; eauto. - inv H. rewrite ind_arity_eq. change PCUICEnvironment.it_mkProd_or_LetIn with it_mkProd_or_LetIn. @@ -108,14 +108,14 @@ Proof. - eapply IHL in H. cbn in H. tauto. Qed. -Lemma typing_spine_red (Σ : global_env_ext) Γ (args args' : list PCUICAst.term) +Lemma typing_spine_red (Σ : global_env_ext) Γ (args args' : list PCUICAst.term) (X : All2 (red Σ Γ) args args') (wfΣ : wf Σ) - (T x x0 : PCUICAst.term) - (t0 : typing_spine Σ Γ x args x0) + (T x x0 : PCUICAst.term) + (t0 : typing_spine Σ Γ x args x0) (c : Σ;;; Γ ⊢ x0 ≤ T) x1 (c0 : Σ;;; Γ ⊢ x1 ≤ x) : isType Σ Γ x1 -> - isType Σ Γ T -> + isType Σ Γ T -> typing_spine Σ Γ x1 args' T. Proof. intros ? ?. revert args' X. @@ -128,7 +128,7 @@ Proof. + eapply IHt0; eauto. eapply red_ws_cumul_pb_inv. unfold subst1. - eapply isType_tProd in i0 as [dom codom]. + eapply isType_tProd in i0 as [dom codom]. eapply (closed_red_red_subst (Δ := [vass na A]) (Γ' := [])); auto. simpl. eapply isType_wf_local in codom. fvs. constructor; auto. eapply into_closed_red; auto. fvs. fvs. @@ -137,11 +137,11 @@ Proof. eapply subject_reduction; tea. Qed. -Lemma it_mkProd_red_Arity {Σ : global_env_ext} {Γ c0 i u l} {wfΣ : wf Σ} : +Lemma it_mkProd_red_Arity {Σ : global_env_ext} {Γ c0 i u l} {wfΣ : wf Σ} : ~ Is_conv_to_Arity Σ Γ (it_mkProd_or_LetIn c0 (mkApps (tInd i u) l)). Proof. intros (? & [] & ?). eapply red_it_mkProd_or_LetIn_mkApps_Ind in X as (? & ? & ?). subst. - eapply it_mkProd_arity in H. eapply isArity_mkApps in H as [[] ]. + eapply it_mkProd_arity in H. eapply isArity_mkApps in H as [[] ]. Qed. Lemma invert_it_Ind_eq_prod: @@ -203,7 +203,7 @@ Proof. * rewrite /mkProd_or_LetIn /=. simpl => /= sp. simpl. dependent elimination sp as [spnil i i' e|spcons i i' e e' sp]. - { exists (Γ0 ++ [vass na ty]). + { exists (Γ0 ++ [vass na ty]). exists args. now rewrite it_mkProd_or_LetIn_app. } eapply ws_cumul_pb_Prod_Prod_inv in e as [eqna dom codom]; pcuic. eapply (substitution0_ws_cumul_pb (t:=hd0)) in codom; eauto. @@ -255,7 +255,7 @@ Proof. eapply PCUICValidity.validity. econstructor; eauto. Qed. -Lemma nIs_conv_to_Arity_nArity {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T} : +Lemma nIs_conv_to_Arity_nArity {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T} : isType Σ Γ T -> ~ Is_conv_to_Arity Σ Γ T -> ~ isArity T. Proof. @@ -270,12 +270,12 @@ Lemma tConstruct_no_Type (Σ : global_env_ext) Γ ind c u x1 : wf Σ -> Is_proof Σ Γ (mkApps (tConstruct ind c u) x1). Proof. intros wfΣ (? & ? & [ | (? & ? & ?)]). - - exfalso. + - exfalso. eapply nIs_conv_to_Arity_nArity; tea. eapply PCUICValidity.validity; tea. eapply type_mkApps_tConstruct_n_conv_arity in t; auto. - exists x, x0. eauto. -Qed. +Qed. (* if a cofixpoint is a type or proof, it is a proof *) @@ -316,7 +316,7 @@ Qed. Lemma typing_spine_wat (Σ : global_env_ext) (Γ : context) (L : list term) (x x0 : term) : wf Σ -> - typing_spine Σ Γ x L x0 -> + typing_spine Σ Γ x L x0 -> isType Σ Γ x0. Proof. intros wfΣ; induction 1; auto. @@ -394,8 +394,8 @@ Lemma sort_typing_spine: forall (Σ : global_env_ext) (Γ : context) (L : list term) (u : Universe.t) (x x0 : term), wf_ext Σ -> is_propositional u -> - typing_spine Σ Γ x L x0 -> - Σ;;; Γ |- x : tSort u -> + typing_spine Σ Γ x L x0 -> + Σ;;; Γ |- x : tSort u -> ∑ u', Σ;;; Γ |- x0 : tSort u' × is_propositional u'. Proof. intros Σ Γ L u x x0 HΣ ? t1 c0. @@ -422,8 +422,8 @@ Qed. Lemma arity_type_inv (Σ : global_env_ext) Γ t T1 T2 : wf_ext Σ -> wf_local Σ Γ -> Σ ;;; Γ |- t : T1 -> isArity T1 -> Σ ;;; Γ |- t : T2 -> Is_conv_to_Arity Σ Γ T2. Proof. - intros wfΣ wfΓ. intros. - destruct (common_typing _ _ X X0) as (? & e & ? & ?). + intros wfΣ wfΓ. intros. + destruct (common_typing _ _ X X0) as (? & e & ? & ?). eapply invert_cumul_arity_l_gen; tea. eapply invert_cumul_arity_r_gen. 2:exact e. exists T1. split; auto. sq. @@ -467,7 +467,7 @@ Lemma leq_term_propositional_sorted_l {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> is_propositional u -> + Σ;;; Γ |- v' : tSort u' -> is_propositional u -> leq_universe (global_ext_constraints Σ) u' u. Proof. intros wf leq Hv Hv' isp. @@ -481,7 +481,7 @@ Lemma leq_term_propopositional_sorted_r {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> is_propositional u' -> + Σ;;; Γ |- v' : tSort u' -> is_propositional u' -> leq_universe (global_ext_constraints Σ) u u'. Proof. intros wfΣ leq hv hv' isp. @@ -579,7 +579,7 @@ Proof. destruct s as [ | (u & ? & ?)]. - eapply invert_cumul_arity_r in e; eauto. destruct e as (? & [] & ?). eapply invert_red_prod in X1 as (? & ? & []); eauto; subst. cbn in H. - econstructor. exists x3. econstructor. + econstructor. exists x3. econstructor. eapply type_reduction_closed; eauto. econstructor; eauto. - sq. eapply cumul_prop1' in e; eauto. eapply inversion_Prod in e as (? & ? & ? & ? & e) ; auto. @@ -587,7 +587,7 @@ Proof. eapply leq_universe_propositional_r in e as H0; cbn; eauto. eexists. split. eassumption. right. eexists. split. eassumption. eapply is_propositional_sort_prod in H0; eauto. - eapply type_Lambda in t1; eauto. + eapply type_Lambda in t1; eauto. now apply PCUICValidity.validity in t1. Qed. @@ -614,7 +614,7 @@ Proof. eapply wcbeval_red; eauto. assumption. Qed. -(* Thanks to the restriction to Prop isWfArity Σ Γ x -> False. @@ -659,11 +659,11 @@ Proof. now eapply it_mkProd_isArity. Qed. -Definition isErasable_Type (Σ : global_env_ext) Γ T := +Definition isErasable_Type (Σ : global_env_ext) Γ T := (Is_conv_to_Arity Σ Γ T + (∑ u : Universe.t, Σ;;; Γ |- T : tSort u × is_propositional u))%type. -Lemma isErasable_any_type {Σ} {wfΣ : wf_ext Σ} {Γ t T} : +Lemma isErasable_any_type {Σ} {wfΣ : wf_ext Σ} {Γ t T} : isErasable Σ Γ t -> Σ ;;; Γ |- t : T -> isErasable_Type Σ Γ T. @@ -680,12 +680,12 @@ Proof. eapply cumul_prop1'; eauto. eapply PCUICValidity.validity; eauto. Qed. -Lemma Is_proof_ty Σ Γ t : +Lemma Is_proof_ty Σ Γ t : wf_ext Σ -> - Is_proof Σ Γ t -> - forall t' ty, + Is_proof Σ Γ t -> + forall t' ty, Σ ;;; Γ |- t : ty -> - Σ ;;; Γ |- t' : ty -> + Σ ;;; Γ |- t' : ty -> Is_proof Σ Γ t'. Proof. intros wfΣ [ty [u [Hty isp]]]. @@ -750,7 +750,7 @@ Proof. eapply leq_universe_sprop_l in leu; tea => //. Qed. -Lemma typing_spine_inj {Σ Γ Δ s args args' u u'} : +Lemma typing_spine_inj {Σ Γ Δ s args args' u u'} : wf_ext Σ -> check_univs -> prop_sub_type = false -> @@ -765,12 +765,12 @@ Proof. eapply is_propositional_lower; tea. apply wf. Qed. -Lemma Is_proof_ind Σ Γ t : +Lemma Is_proof_ind Σ Γ t : wf_ext Σ -> - Is_proof Σ Γ t -> - forall t' ind u args args', + Is_proof Σ Γ t -> + forall t' ind u args args', Σ ;;; Γ |- t : mkApps (tInd ind u) args -> - Σ ;;; Γ |- t' : mkApps (tInd ind u) args' -> + Σ ;;; Γ |- t' : mkApps (tInd ind u) args' -> Is_proof Σ Γ t'. Proof. intros wfΣ [ty [u [Hty isp]]]. @@ -806,21 +806,21 @@ Proof. eapply inversion_Case in hc as [mdecl [idecl [isdecl [indices ?]]]]; eauto. eapply inversion_Case in hr as [mdecl' [idecl' [isdecl' [indices' ?]]]]; eauto. destruct (declared_inductive_inj isdecl isdecl'). subst mdecl' idecl'. - intros hp. + intros hp. epose proof (Is_proof_ind _ _ _ wfΣ hp). destruct p0 as [[] ?]. destruct p1 as [[] ?]. exact (X _ _ _ _ _ scrut_ty scrut_ty0). Qed. Lemma Is_proof_app {Σ Γ t args ty} {wfΣ : wf_ext Σ} : - Is_proof Σ Γ t -> + Is_proof Σ Γ t -> Σ ;;; Γ |- mkApps t args : ty -> Is_proof Σ Γ (mkApps t args). Proof. intros [ty' [u [Hty [isp pu]]]] Htargs. eapply PCUICValidity.inversion_mkApps in Htargs as [A [Ht sp]]. - pose proof (PCUICValidity.validity Hty). - pose proof (PCUICValidity.validity Ht). + pose proof (PCUICValidity.validity Hty). + pose proof (PCUICValidity.validity Ht). epose proof (PCUICPrincipality.common_typing _ wfΣ Hty Ht) as [C [Cty [Cty' Ht'']]]. eapply PCUICSpine.typing_spine_strengthen in sp. 3:tea. edestruct (sort_typing_spine _ _ _ u _ _ _ pu sp) as [u' [Hty' isp']]. @@ -831,7 +831,7 @@ Proof. now eapply validity. Qed. -Lemma isErasable_Propositional {Σ : global_env_ext} {Γ ind n u args} : +Lemma isErasable_Propositional {Σ : global_env_ext} {Γ ind n u args} : wf_ext Σ -> isErasable Σ Γ (mkApps (tConstruct ind n u) args) -> isPropositional Σ ind true. Proof. @@ -863,7 +863,7 @@ Proof. eapply validity. econstructor; tea. Qed. -Lemma nisErasable_Propositional {Σ : global_env_ext} {Γ ind n u} : +Lemma nisErasable_Propositional {Σ : global_env_ext} {Γ ind n u} : wf_ext Σ -> welltyped Σ Γ (tConstruct ind n u) -> (isErasable Σ Γ (tConstruct ind n u) -> False) -> isPropositional Σ ind false. @@ -887,7 +887,7 @@ Proof. rewrite onc.(cstr_eq) in e, X. rewrite !subst_instance_it_mkProd_or_LetIn !PCUICLiftSubst.subst_it_mkProd_or_LetIn in e, X. len in e; len in X. - rewrite subst_cstr_concl_head in e, X. + rewrite subst_cstr_concl_head in e, X. destruct decli. eapply nth_error_Some_length in H1; eauto. rewrite -it_mkProd_or_LetIn_app in e, X. exists (subst_instance_univ u (ind_sort x0)). @@ -910,9 +910,9 @@ Proof. do 2 constructor. rewrite is_propositional_subst_instance in sorts, sorts' |- *. specialize (sorts' isp). rewrite -sorts'. reflexivity. -Qed. +Qed. -Lemma isPropositional_propositional Σ (Σ' : E.global_context) ind mdecl idecl mdecl' idecl' : +Lemma isPropositional_propositional Σ (Σ' : E.global_context) ind mdecl idecl mdecl' idecl' : PCUICAst.declared_inductive Σ ind mdecl idecl -> EGlobalEnv.declared_inductive Σ' ind mdecl' idecl' -> erases_mutual_inductive_body mdecl mdecl' -> @@ -929,14 +929,14 @@ Proof. rewrite isP. intros ->. f_equal. f_equal. now rewrite indp. Qed. -Lemma isPropositional_propositional_cstr Σ (Σ' : E.global_context) ind c mdecl idecl cdecl mdecl' idecl' : +Lemma isPropositional_propositional_cstr Σ (Σ' : E.global_context) ind c mdecl idecl cdecl mdecl' idecl' : wf Σ -> PCUICAst.declared_constructor Σ (ind, c) mdecl idecl cdecl -> EGlobalEnv.declared_inductive Σ' ind mdecl' idecl' -> erases_mutual_inductive_body mdecl mdecl' -> erases_one_inductive_body idecl idecl' -> - forall b, isPropositional Σ ind b -> - EGlobalEnv.constructor_isprop_pars_decl Σ' ind c = + forall b, isPropositional Σ ind b -> + EGlobalEnv.constructor_isprop_pars_decl Σ' ind c = Some (b, mdecl.(ind_npars), EAst.mkConstructor cdecl.(cstr_name) (context_assumptions cdecl.(cstr_args))). Proof. intros wfΣ declc decli' em ei b isp. @@ -959,7 +959,7 @@ Qed. Lemma eval_tCase {cf : checker_flags} {Σ : global_env_ext} ci p discr brs res T : wf Σ -> Σ ;;; [] |- tCase ci p discr brs : T -> - eval Σ (tCase ci p discr brs) res -> + eval Σ (tCase ci p discr brs) res -> ∑ c u args, PCUICReduction.red Σ [] (tCase ci p discr brs) (tCase ci p ((mkApps (tConstruct ci.(ci_ind) c u) args)) brs). Proof. intros wf wt H. depind H; try now (cbn in *; congruence). @@ -967,7 +967,7 @@ Proof. eexists _, _, _. eapply PCUICReduction.red_case_c. eapply wcbeval_red. 2: eauto. eapply cinv. - eapply inversion_Case in wt as wt'; eauto. destruct wt' as (? & ? & ? & ? & cinv & ?). assert (Hred1 : PCUICReduction.red Σ [] (tCase ip p discr brs) (tCase ip p (mkApps fn args) brs)). { - etransitivity. { eapply PCUICReduction.red_case_c. eapply wcbeval_red. 2: eauto. eapply cinv. } + etransitivity. { eapply PCUICReduction.red_case_c. eapply wcbeval_red. 2: eauto. eapply cinv. } econstructor. econstructor. rewrite closed_unfold_cofix_cunfold_eq. eauto. enough (closed (mkApps (tCoFix mfix idx) args)) as Hcl by (rewrite closedn_mkApps in Hcl; solve_all). @@ -1000,7 +1000,7 @@ Proof. Qed. Lemma isErasable_unfold_cofix {Σ : global_env_ext} {Γ mfix idx} {wfΣ : wf Σ} decl : - isErasable Σ Γ (tCoFix mfix idx) -> + isErasable Σ Γ (tCoFix mfix idx) -> nth_error mfix idx = Some decl -> isErasable Σ Γ (subst0 (cofix_subst mfix) (dbody decl)). Proof. diff --git a/erasure/theories/EAst.v b/erasure/theories/EAst.v index 6e467d144..abfe3aa15 100644 --- a/erasure/theories/EAst.v +++ b/erasure/theories/EAst.v @@ -170,7 +170,7 @@ Notation " Γ ,, d " := (snoc Γ d) (at level 20, d at next level) : erasure. (** *** Environments *) -Record constructor_body := +Record constructor_body := mkConstructor { cstr_name : ident; cstr_nargs : nat (* arity, w/o lets, w/o parameters *) @@ -199,9 +199,9 @@ Record mutual_inductive_body := { ind_bodies : list one_inductive_body }. Derive NoConfusion for mutual_inductive_body. -Definition cstr_arity (mdecl : mutual_inductive_body) (cdecl : constructor_body) := - (mdecl.(ind_npars) + cdecl.(cstr_nargs))%nat. - +Definition cstr_arity (mdecl : mutual_inductive_body) (cdecl : constructor_body) := + (mdecl.(ind_npars) + cdecl.(cstr_nargs))%nat. + (** See [constant_body] from [declarations.ml] *) Record constant_body := { cst_body : option term }. diff --git a/erasure/theories/EAstUtils.v b/erasure/theories/EAstUtils.v index 3631386cd..d5515fc90 100644 --- a/erasure/theories/EAstUtils.v +++ b/erasure/theories/EAstUtils.v @@ -242,7 +242,7 @@ Proof. * split => //. rewrite mkApps_app in eq. cbn in eq. noconf eq. rewrite remove_last_app. split => //. - now rewrite last_last. + now rewrite last_last. Qed. Ltac solve_discr := @@ -259,8 +259,8 @@ Ltac solve_discr := Definition isRel t := match t with - | tRel _ => true - | _ => false + | tRel _ => true + | _ => false end. Definition isEvar t := @@ -293,7 +293,7 @@ Definition isPrim t := | _ => false end. - + Definition isBox t := match t with | tBox => true @@ -376,13 +376,13 @@ Fixpoint term_global_deps (t : EAst.term) := | EAst.tApp x y | EAst.tLetIn _ x y => KernameSet.union (term_global_deps x) (term_global_deps y) | EAst.tCase (ind, _) x brs => - KernameSet.union (KernameSet.singleton (inductive_mind ind)) - (List.fold_left (fun acc x => KernameSet.union (term_global_deps (snd x)) acc) brs + KernameSet.union (KernameSet.singleton (inductive_mind ind)) + (List.fold_left (fun acc x => KernameSet.union (term_global_deps (snd x)) acc) brs (term_global_deps x)) | EAst.tFix mfix _ | EAst.tCoFix mfix _ => List.fold_left (fun acc x => KernameSet.union (term_global_deps (EAst.dbody x)) acc) mfix KernameSet.empty - | EAst.tProj p c => + | EAst.tProj p c => KernameSet.union (KernameSet.singleton (inductive_mind p.(proj_ind))) (term_global_deps c) | _ => KernameSet.empty diff --git a/erasure/theories/ECSubst.v b/erasure/theories/ECSubst.v index 65a0695d3..38aedb129 100644 --- a/erasure/theories/ECSubst.v +++ b/erasure/theories/ECSubst.v @@ -44,11 +44,11 @@ Definition substl defs body : term := fold_left (fun bod term => csubst term 0 bod) defs body. -(** It is equivalent to general substitution on closed terms. *) +(** It is equivalent to general substitution on closed terms. *) Lemma closed_subst t k u : closed t -> csubst t k u = subst [t] k u. Proof. - revert k; induction u using term_forall_list_ind; intros k Hs; + revert k; induction u using term_forall_list_ind; intros k Hs; simpl; try f_equal; eauto; solve_all. - destruct (PeanoNat.Nat.compare_spec k n). + subst k. @@ -71,7 +71,7 @@ Proof. rewrite closed_subst; try eassumption. change (a :: s) with ([a] ++ s). rewrite subst_app_decomp. cbn. - repeat f_equal. rewrite lift_closed; eauto. + repeat f_equal. rewrite lift_closed; eauto. Qed. (* @@ -130,9 +130,9 @@ Proof. Qed. *) -Lemma closed_csubst t k u : - closed t -> - closedn (S k) u -> +Lemma closed_csubst t k u : + closed t -> + closedn (S k) u -> closedn k (ECSubst.csubst t 0 u). Proof. intros. @@ -141,9 +141,9 @@ Proof. rewrite andb_true_r. eapply closed_upwards; tea. lia. Qed. -Lemma closed_substl ts k u : - forallb (closedn 0) ts -> - closedn (#|ts| + k) u -> +Lemma closed_substl ts k u : + forallb (closedn 0) ts -> + closedn (#|ts| + k) u -> closedn k (ECSubst.substl ts u). Proof. induction ts in u |- *; cbn => //. @@ -171,9 +171,9 @@ Proof. destruct x0; cbn in *. f_equal; auto. Qed. -Lemma subst_csubst_comm l t k b : +Lemma subst_csubst_comm l t k b : forallb (closedn 0) l -> closed t -> - subst l 0 (csubst t (#|l| + k) b) = + subst l 0 (csubst t (#|l| + k) b) = csubst t k (subst l 0 b). Proof. intros hl cl. @@ -181,17 +181,17 @@ Proof. rewrite distr_subst. f_equal. symmetry. solve_all. rewrite subst_closed //. - eapply closed_upwards; tea. lia. + eapply closed_upwards; tea. lia. Qed. -Lemma substl_csubst_comm l t k b : +Lemma substl_csubst_comm l t k b : forallb (closedn 0) l -> closed t -> - substl l (csubst t (#|l| + k) b) = + substl l (csubst t (#|l| + k) b) = csubst t k (substl l b). Proof. intros hl cl. rewrite substl_subst //. - rewrite substl_subst //. + rewrite substl_subst //. apply subst_csubst_comm => //. Qed. diff --git a/erasure/theories/EConstructorsAsBlocks.v b/erasure/theories/EConstructorsAsBlocks.v index d77c23bea..167a4ae2a 100644 --- a/erasure/theories/EConstructorsAsBlocks.v +++ b/erasure/theories/EConstructorsAsBlocks.v @@ -1,8 +1,8 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import Utf8 Program. -From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap. +From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap. From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EArities - ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap + ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap EWcbvEval EEtaExpanded ECSubst EWcbvEvalEtaInd EProgram. Local Open Scope string_scope. @@ -29,23 +29,23 @@ Section transform_blocks. Section Def. Import TermSpineView. - Equations? transform_blocks (t : term) : term + Equations? transform_blocks (t : term) : term by wf t (fun x y : EAst.term => size x < size y) := | e with TermSpineView.view e := { | tRel i => EAst.tRel i | tEvar ev args => EAst.tEvar ev (map_InP args (fun x H => transform_blocks x)) | tLambda na M => EAst.tLambda na (transform_blocks M) - | tApp u v napp nnil with construct_viewc u := - { | view_construct ind i block_args with GlobalContextMap.lookup_constructor_pars_args Σ ind i := { - | Some (npars, nargs) => + | tApp u v napp nnil with construct_viewc u := + { | view_construct ind i block_args with GlobalContextMap.lookup_constructor_pars_args Σ ind i := { + | Some (npars, nargs) => let args := map_InP v (fun x H => transform_blocks x) in let '(args, rest) := MCList.chop nargs args in EAst.mkApps (EAst.tConstruct ind i args) rest - | None => + | None => let args := map_InP v (fun x H => transform_blocks x) in - EAst.tConstruct ind i args } + EAst.tConstruct ind i args } | view_other _ _ => mkApps (transform_blocks u) (map_InP v (fun x H => transform_blocks x)) } - + | tLetIn na b b' => EAst.tLetIn na (transform_blocks b) (transform_blocks b') | tCase ind c brs => let brs' := map_InP brs (fun x H => (x.1, transform_blocks x.2)) in @@ -60,7 +60,7 @@ Section transform_blocks. | tBox => EAst.tBox | tVar n => EAst.tVar n | tConst n => EAst.tConst n - | tConstruct ind i block_args => EAst.tConstruct ind i [] + | tConstruct ind i block_args => EAst.tConstruct ind i [] | tPrim p => EAst.tPrim p }. Proof. all:try lia. @@ -78,7 +78,7 @@ Section transform_blocks. - now eapply size_mkApps_f. - change (fun x => size (id x)) with size in H. eapply (In_size id size) in H. unfold id in H. - change (fun x => size x) with size in H. + change (fun x => size x) with size in H. pose proof (size_mkApps_l napp nnil). lia. - eapply (In_size snd size) in H. cbn in *. lia. Qed. @@ -88,7 +88,7 @@ Section transform_blocks. Hint Rewrite @map_InP_spec : transform_blocks. Arguments eqb : simpl never. - + Opaque transform_blocks_unfold_clause_1. Opaque transform_blocks. Opaque isEtaExp. @@ -131,21 +131,21 @@ Section transform_blocks. Transparent isEtaExp_unfold_clause_1. Transparent transform_blocks_unfold_clause_1. - + Local Lemma transform_blocks_mkApps f v : - ~~ isApp f -> - transform_blocks (mkApps f v) = match construct_viewc f with - | view_construct ind i block_args => + ~~ isApp f -> + transform_blocks (mkApps f v) = match construct_viewc f with + | view_construct ind i block_args => match lookup_constructor_pars_args Σ ind i with - | Some (npars, nargs) => + | Some (npars, nargs) => let args := map transform_blocks v in let '(args, rest) := MCList.chop nargs args in EAst.mkApps (EAst.tConstruct ind i args) rest - | None => + | None => let args := map transform_blocks v in - EAst.tConstruct ind i args + EAst.tConstruct ind i args end - | view_other _ _ => mkApps (transform_blocks f) (map transform_blocks v) + | view_other _ _ => mkApps (transform_blocks f) (map transform_blocks v) end. Proof using Type. intros napp; simp transform_blocks. @@ -174,9 +174,9 @@ Section transform_blocks. transform_blocks f = let (fn, args) := decompose_app f in match construct_viewc fn with - | view_construct kn c _ => + | view_construct kn c _ => match lookup_constructor_pars_args Σ kn c with - | Some (npars, nargs) => + | Some (npars, nargs) => let args := map (transform_blocks) args in let '(args, rest) := MCList.chop nargs args in mkApps (tConstruct kn c args) rest @@ -195,12 +195,12 @@ Section transform_blocks. Qed. Lemma transform_blocks_mkApps_eta (P : term -> Prop) fn args : - (* wf_glob Σ -> + (* wf_glob Σ -> *)~~ EAst.isApp fn -> isEtaExp Σ (mkApps fn args) -> (match construct_viewc fn with - | view_construct kn c block_args => - forall pars nargs, + | view_construct kn c block_args => + forall pars nargs, lookup_constructor_pars_args Σ kn c = Some (pars, nargs) -> let cargs := map transform_blocks args in let '(cargs, rest) := MCList.chop nargs cargs in @@ -223,9 +223,9 @@ Section transform_blocks. destruct chop eqn:eqch => //. move => /andP[] => //. + intros ht. rewrite transform_blocks_mkApps // vc //. - Qed. + Qed. - Lemma transform_blocks_mkApps_eta_fn f args : isEtaExp Σ f -> + Lemma transform_blocks_mkApps_eta_fn f args : isEtaExp Σ f -> transform_blocks (mkApps f args) = mkApps (transform_blocks f) (map (transform_blocks) args). Proof. intros ef. @@ -240,7 +240,7 @@ Section transform_blocks. destruct (construct_viewc t) eqn:vc. + move=> /andP[] etanl etal. destruct lookup_constructor_pars_args as [[pars args']|] eqn:hl => //. - cbn. + cbn. rewrite chop_firstn_skipn. rewrite transform_blocks_decompose. rewrite decompose_app_mkApps // /= hl. @@ -248,12 +248,12 @@ Section transform_blocks. rewrite - mkApps_app. move: etanl. rewrite /isEtaExp_app hl. move => /andP[] /Nat.leb_le => hl' hall. - rewrite firstn_map. + rewrite firstn_map. rewrite firstn_app. assert (args' - #|l| = 0) as -> by lia. rewrite firstn_O // app_nil_r. f_equal. f_equal. rewrite firstn_map //. rewrite map_app skipn_map. - rewrite skipn_app. len. + rewrite skipn_app. len. assert (args' - #|l| = 0) as -> by lia. now rewrite skipn_0 -skipn_map. move: etanl. rewrite /isEtaExp_app hl //. @@ -264,7 +264,7 @@ Section transform_blocks. now rewrite map_app. Qed. - Lemma transform_blocks_csubst a k b : + Lemma transform_blocks_csubst a k b : closed a -> isEtaExp Σ a -> isEtaExp Σ b -> @@ -276,7 +276,7 @@ Section transform_blocks. rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; unfold test_def in *; simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. - + - destruct Nat.compare => //. - f_equal. solve_all. move/andP: b => [] _ he. solve_all. - rewrite csubst_mkApps. @@ -331,8 +331,8 @@ Section transform_blocks. unfold isEtaExp_app in etaapp. destruct lookup_constructor_pars_args as [[pars args]|] eqn:eqpars => //. Qed. - - Lemma transform_blocks_substl s t : + + Lemma transform_blocks_substl s t : forallb (closedn 0) s -> forallb (isEtaExp Σ) s -> isEtaExp Σ t -> @@ -357,7 +357,7 @@ Section transform_blocks. rewrite forallb_rev forallb_skipn //. now rewrite map_rev map_skipn. Qed. - + Lemma transform_blocks_fix_subst mfix : EGlobalEnv.fix_subst (map (map_def transform_blocks) mfix) = map transform_blocks (EGlobalEnv.fix_subst mfix). Proof using Type. unfold EGlobalEnv.fix_subst. @@ -376,7 +376,7 @@ Section transform_blocks. f_equal; auto. now simp transform_blocks. Qed. - Lemma transform_blocks_cunfold_fix mfix idx n f : + Lemma transform_blocks_cunfold_fix mfix idx n f : forallb (closedn 0) (fix_subst mfix) -> forallb (fun d => isLambda (dbody d) && isEtaExp Σ (dbody d)) mfix -> cunfold_fix mfix idx = Some (n, f) -> @@ -395,8 +395,8 @@ Section transform_blocks. discriminate. Qed. - - Lemma transform_blocks_cunfold_cofix mfix idx n f : + + Lemma transform_blocks_cunfold_cofix mfix idx n f : forallb (closedn 0) (cofix_subst mfix) -> forallb (isEtaExp Σ ∘ dbody) mfix -> cunfold_cofix mfix idx = Some (n, f) -> @@ -414,39 +414,39 @@ Section transform_blocks. discriminate. Qed. - Lemma transform_blocks_nth {n l d} : + Lemma transform_blocks_nth {n l d} : transform_blocks (nth n l d) = nth n (map transform_blocks l) (transform_blocks d). Proof using Type. induction l in n |- *; destruct n; simpl; auto. Qed. - Definition switch_constructor_as_block fl : WcbvFlags := + Definition switch_constructor_as_block fl : WcbvFlags := EWcbvEval.Build_WcbvFlags fl.(@with_prop_case) fl.(@with_guarded_fix) true. End transform_blocks. -Definition transform_blocks_constant_decl Σ cb := +Definition transform_blocks_constant_decl Σ cb := {| cst_body := option_map (transform_blocks Σ) cb.(cst_body) |}. - + Definition transform_blocks_decl Σ d := match d with | ConstantDecl cb => ConstantDecl (transform_blocks_constant_decl Σ cb) | InductiveDecl idecl => d end. -Definition transform_blocks_env Σ := +Definition transform_blocks_env Σ := map (on_snd (transform_blocks_decl Σ)) Σ.(GlobalContextMap.global_decls). Definition transform_blocks_program (p : eprogram_env) := (transform_blocks_env p.1, transform_blocks p.1 p.2). -Definition switch_cstr_as_blocks (fl : EEnvFlags) := +Definition switch_cstr_as_blocks (fl : EEnvFlags) := {| has_axioms := has_axioms; has_cstr_params := has_cstr_params; term_switches := term_switches; cstr_as_blocks := true |}. -Definition block_wcbv_flags := +Definition block_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := false ; with_constructor_as_block := true |}. Local Hint Resolve wellformed_closed : core. @@ -459,7 +459,7 @@ Proof. intros hasp. induction 1; cbn => //. case: eqb_spec => [|]. - - intros ->. destruct d => //. intros [= <-]. + - intros ->. destruct d => //. intros [= <-]. cbn in H0. unfold wf_minductive in H0. rtoProp. cbn in H0. rewrite hasp in H0; now eapply eqb_eq in H0. - intros _. eapply IHwf_glob. @@ -530,13 +530,13 @@ Qed. Lemma transform_blocks_tApp (efl : EEnvFlags) {Σ : GlobalContextMap.t} t a (P : term -> Set) k : has_cstr_params = false -> - wf_glob Σ -> + wf_glob Σ -> wellformed Σ k (tApp t a) -> (let (fn, args) := decompose_app (tApp t a) in match construct_viewc fn with - | view_construct kn c block_args => + | view_construct kn c block_args => match GlobalContextMap.lookup_constructor_pars_args Σ kn c with - | Some (0, nargs) => + | Some (0, nargs) => let cargs := map (transform_blocks Σ) args in let '(cargs, rest) := MCList.chop nargs cargs in (args <> [] /\ t = mkApps (tConstruct kn c block_args) (remove_last args) /\ a = last args a) -> @@ -560,7 +560,7 @@ Proof. rewrite GlobalContextMap.lookup_constructor_pars_args_spec. destruct (wellformed_lookup_constructor_pars_args wfΣ haspars wfc). rewrite e. cbn. - destruct chop eqn:eqch => //. + destruct chop eqn:eqch => //. intros. apply H1. intuition auto. + pose proof (decompose_app_notApp _ _ _ da). pose proof (EInduction.decompose_app_app _ _ _ _ da). @@ -572,9 +572,9 @@ Proof. Qed. Lemma eval_mkApps_Construct_inv {fl : WcbvFlags} Σ kn c args e block_args mdecl idecl cdecl : - with_constructor_as_block = false -> + with_constructor_as_block = false -> lookup_constructor Σ kn c = Some (mdecl, idecl, cdecl) -> - eval Σ (mkApps (tConstruct kn c block_args) args) e -> + eval Σ (mkApps (tConstruct kn c block_args) args) e -> ∑ args', (e = mkApps (tConstruct kn c []) args') × All2 (eval Σ) args args' × block_args = [] × #|args| <= cstr_arity mdecl cdecl. Proof. intros hblock hlook. @@ -584,9 +584,9 @@ Proof. depelim ev; try solve_discr. destruct (IHargs _ ev1) as [? []]. solve_discr. all:try specialize (IHargs _ ev1) as [? []]; try solve_discr; try noconf H. - * destruct p as (? & ? & ?). exists (x0 ++ [a']). split => //. + * destruct p as (? & ? & ?). exists (x0 ++ [a']). split => //. rewrite mkApps_app /= //. split => //. eapply All2_app; eauto. - split => //. eapply All2_length in a. len. rewrite e1 in hlook; invs hlook. lia. + split => //. eapply All2_length in a. len. rewrite e1 in hlook; invs hlook. lia. * destruct p as (? & ? & ?). subst f'. cbn in i. rewrite isConstructApp_mkApps in i. cbn in i. @@ -638,8 +638,8 @@ Proof. eapply IHt1. cbn in Hwf'. rtoProp. intuition. Qed. -Lemma lookup_env_transform_blocks {Σ : GlobalContextMap.t} kn : - lookup_env (transform_blocks_env Σ) kn = +Lemma lookup_env_transform_blocks {Σ : GlobalContextMap.t} kn : + lookup_env (transform_blocks_env Σ) kn = option_map (transform_blocks_decl Σ) (lookup_env Σ kn). Proof. unfold transform_blocks_env. @@ -672,14 +672,14 @@ Lemma transform_wellformed' {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : has_cstr_params = false -> cstr_as_blocks = false -> has_tApp -> - wf_glob Σ -> + wf_glob Σ -> @wellformed efl Σ n t -> isEtaExp Σ t -> @wellformed (switch_cstr_as_blocks efl) Σ n (transform_blocks Σ t). Proof. intros hasp cstrbl hasa. - revert n. funelim (transform_blocks Σ t); simp_eta; cbn -[transform_blocks - lookup_inductive lookup_constructor lookup_constructor_pars_args + revert n. funelim (transform_blocks Σ t); simp_eta; cbn -[transform_blocks + lookup_inductive lookup_constructor lookup_constructor_pars_args GlobalContextMap.lookup_constructor_pars_args isEtaExp]; intros m Hwf Hw; rtoProp; try split; eauto. all: rewrite ?map_InP_spec; toAll; eauto; try now solve_all. - rewrite cstrbl in H0. destruct H2. unfold isEtaExp_app in H2. unfold lookup_constructor_pars_args in *. @@ -698,7 +698,7 @@ Proof. destruct construct_viewc; eauto. cbn in d. eauto. rtoProp. eauto. repeat solve_all. - Opaque isEtaExp. destruct chop eqn:Ec. rewrite !wellformed_mkApps in Hw |- * => //. rtoProp. - rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq. + rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq. cbn -[lookup_constructor transform_blocks ] in *. intros. rtoProp. rewrite isEtaExp_Constructor in H2. rtoProp. unfold isEtaExp_app in *. unfold lookup_constructor_pars_args in H2. @@ -727,14 +727,14 @@ Proof. - rewrite isEtaExp_Constructor in H0. rtoProp. rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq; unfold lookup_constructor_pars_args in *. destruct lookup_constructor as [ [[]] | ]; cbn in Heq; try congruence. - cbn. split; eauto. rewrite wellformed_mkApps in Hw; eauto. rtoProp. solve_all. + cbn. split; eauto. rewrite wellformed_mkApps in Hw; eauto. rtoProp. solve_all. Qed. Lemma transform_wellformed_decl' {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : has_cstr_params = false -> cstr_as_blocks = false -> has_tApp -> - wf_glob Σ -> + wf_glob Σ -> @wf_global_decl efl Σ d -> isEtaExp_decl Σ d -> @wf_global_decl (switch_cstr_as_blocks efl) Σ (transform_blocks_decl Σ d). @@ -747,7 +747,7 @@ Qed. From MetaCoq.Erasure Require Import EGenericMapEnv. -Lemma transform_blocks_extends {efl : EEnvFlags} : +Lemma transform_blocks_extends {efl : EEnvFlags} : has_tApp -> ∀ (Σ : GlobalContextMap.t) (t : term) (n : nat), wellformed Σ n t @@ -762,7 +762,7 @@ Proof. all: try rewrite !map_InP_spec. all: try toAll. all: try f_equal. - all: rtoProp; solve_all. + all: rtoProp; solve_all. - f_equal. eauto. solve_all. - unfold wf_fix in *. rtoProp. f_equal. solve_all. - unfold wf_fix in *. rtoProp. f_equal. solve_all. @@ -773,7 +773,7 @@ Proof. rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq. rewrite wellformed_mkApps in H0 => //. rewrite transform_blocks_mkApps => //. rtoProp. cbn [construct_viewc]. unfold lookup_constructor_pars_args in *. - destruct (lookup_constructor Σ) as [ [[]] | ] eqn:E'; invs Heq. + destruct (lookup_constructor Σ) as [ [[]] | ] eqn:E'; invs Heq. erewrite extends_lookup_constructor; eauto. cbn. destruct (chop (cstr_nargs c) (map (transform_blocks Σ') v) ) eqn:Ec. rewrite !chop_firstn_skipn in E, Ec. invs E. invs Ec. @@ -786,7 +786,7 @@ Proof. Qed. -Lemma transform_blocks_decl_extends {efl : EEnvFlags} : +Lemma transform_blocks_decl_extends {efl : EEnvFlags} : has_tApp -> ∀ (Σ : GlobalContextMap.t) t, wf_global_decl Σ t @@ -807,7 +807,7 @@ Lemma transform_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : has_cstr_params = false -> cstr_as_blocks = false -> has_tApp -> - wf_glob Σ -> + wf_glob Σ -> @wellformed efl Σ n t -> isEtaExp Σ t -> @wellformed (switch_cstr_as_blocks efl) (transform_blocks_env Σ) n (transform_blocks Σ t). @@ -815,10 +815,10 @@ Proof. intros. eapply gen_transform_wellformed_irrel; eauto. eapply transform_wellformed'; eauto. Qed. - + (*Lemma optimize_wellformed_decl_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : wf_glob Σ -> - wf_global_decl (efl := env_flags) Σ d -> + wf_global_decl (efl := env_flags) Σ d -> wf_global_decl (efl := env_flags_blocks) (transform_blocks_env Σ) d. Proof. intros wf; destruct d => /= //. @@ -830,9 +830,9 @@ Lemma optimize_decl_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : has_cstr_params = false -> cstr_as_blocks = false -> has_tApp -> - wf_glob (efl := efl) Σ -> - forall d, - wf_global_decl (efl := efl) Σ d -> + wf_glob (efl := efl) Σ -> + forall d, + wf_global_decl (efl := efl) Σ d -> isEtaExp_decl Σ d -> wf_global_decl (efl := switch_cstr_as_blocks efl) (transform_blocks_env Σ) (transform_blocks_decl Σ d). Proof. @@ -843,7 +843,7 @@ Proof. intros hwf etat. eapply transform_wellformed => //. Qed. -Lemma fresh_global_optimize_env {Σ : GlobalContextMap.t} kn : +Lemma fresh_global_optimize_env {Σ : GlobalContextMap.t} kn : fresh_global kn Σ -> fresh_global kn (transform_blocks_env Σ). Proof. @@ -852,7 +852,7 @@ Proof. now eapply Forall_map; cbn. Qed. -Lemma fresh_global_map_on_snd Σ f kn : +Lemma fresh_global_map_on_snd Σ f kn : fresh_global kn Σ -> fresh_global kn (map (on_snd f) Σ). Proof. @@ -866,7 +866,7 @@ Lemma transform_wf_global {efl : EEnvFlags} {Σ : GlobalContextMap.t} : EEtaExpanded.isEtaExp_env Σ -> wf_glob (efl := efl) Σ -> wf_glob (efl := switch_cstr_as_blocks efl) (transform_blocks_env Σ). Proof. - intros hasp cstrbl hasapp etag wfg. + intros hasp cstrbl hasapp etag wfg. destruct Σ as [Σ map repr wf]; cbn in *. revert etag wfg. assert (extends Σ Σ). now exists []. @@ -908,15 +908,15 @@ Lemma transform_blocks_eval {efl : EEnvFlags} (fl := EWcbvEval.target_wcbv_flags has_cstr_params = false -> has_tApp -> forall (Σ : GlobalContextMap.t), isEtaExp_env Σ -> @wf_glob efl Σ -> - forall t t', + forall t t', @wellformed efl Σ 0 t -> - isEtaExp Σ t -> + isEtaExp Σ t -> EWcbvEval.eval Σ t t' -> @EWcbvEval.eval block_wcbv_flags (transform_blocks_env Σ) (transform_blocks Σ t) (transform_blocks Σ t'). Proof. intros cstrbl haspars hasapp Σ etaΣ wfΣ. - eapply - (EWcbvEvalEtaInd.eval_preserve_mkApps_ind fl eq_refl (efl := efl) Σ _ + eapply + (EWcbvEvalEtaInd.eval_preserve_mkApps_ind fl eq_refl (efl := efl) Σ _ (wellformed Σ) (Qpres := Qpreserves_wellformed efl _ cstrbl wfΣ)) => //; eauto. { intros. eapply EWcbvEval.eval_wellformed => //; tea. } all:intros *. @@ -939,7 +939,7 @@ Proof. eapply transform_blocks_tApp; eauto. cbn. rtoProp; eauto. destruct decompose_app as [fn args] eqn:heq. destruct construct_viewc eqn:heqv. - + rewrite GlobalContextMap.lookup_constructor_pars_args_spec; + + rewrite GlobalContextMap.lookup_constructor_pars_args_spec; destruct lookup_constructor_pars_args as [[] |] => // /=. destruct n0; eauto. destruct chop eqn:eqch. @@ -955,7 +955,7 @@ Proof. simp transform_blocks. * eauto. * rewrite transform_blocks_csubst in e; eauto. - 1: now simp_eta in i10. + 1: now simp_eta in i10. now rewrite - transform_blocks_equation_1. - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. simp transform_blocks. rewrite -!transform_blocks_equation_1. @@ -977,10 +977,10 @@ Proof. + unfold constructor_isprop_pars_decl. rewrite lookup_constructor_transform_blocks. cbn [fst]. rewrite eqc //= H8 //. - + now rewrite map_InP_spec nth_error_map H3; eauto. + + now rewrite map_InP_spec nth_error_map H3; eauto. + len. + rewrite H9. len. - + rewrite wellformed_mkApps in i4 => //. + + rewrite wellformed_mkApps in i4 => //. rewrite isEtaExp_Constructor in i6 => //. rtoProp. rewrite -transform_blocks_iota_red. * solve_all. @@ -1006,10 +1006,10 @@ Proof. * eauto. * revert e1. set (x := transform_blocks Σ f5). simp transform_blocks. - * rewrite map_InP_spec. + * rewrite map_InP_spec. cbn in i8. unfold wf_fix in i8. rtoProp. erewrite <- transform_blocks_cunfold_fix => //. - all: eauto. + all: eauto. eapply closed_fix_subst. solve_all. destruct x; cbn in H5 |- *. eauto. simp_eta in i10. * eauto. @@ -1028,7 +1028,7 @@ Proof. rewrite isEtaExp_Constructor in i1. rtoProp. rewrite isEtaExp_Constructor in H3. rtoProp. unfold isEtaExp_app in *. - rewrite E2 in H3, H5. + rewrite E2 in H3, H5. eapply leb_complete in H3, H5. exfalso. enough (n0 >= #|l|). @@ -1069,7 +1069,7 @@ Proof. econstructor. eapply transform_blocks_declared_constant; eauto. destruct decl. cbn in *. now rewrite H0. - eauto. + eauto. - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. rewrite transform_blocks_mkApps //= in e0. simp transform_blocks in e0; rewrite -!transform_blocks_equation_1 in e0. @@ -1088,7 +1088,7 @@ Proof. rewrite lookup_constructor_transform_blocks. cbn [fst]. rewrite hc //= H1 H6. reflexivity. + len. - + rewrite nth_error_map /=. rewrite H6 in H2; rewrite -H2 in H4; rewrite H4; eauto. + + rewrite nth_error_map /=. rewrite H6 in H2; rewrite -H2 in H4; rewrite H4; eauto. - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. eapply transform_blocks_tApp; eauto. cbn; rtoProp; eauto. destruct decompose_app as [f args] eqn:heq. @@ -1112,9 +1112,9 @@ Proof. cbn [plus]. destruct chop eqn:heqch. intros [hl [ht ha]]. rewrite ht in H1. rewrite isConstructApp_mkApps isPrimApp_mkApps orb_true_r in H1 => //. * eapply eval_app_cong; eauto. - revert H1. + revert H1. destruct f'; try now cbn; tauto. - intros H. cbn in H. + intros H. cbn in H. rewrite transform_blocks_isConstructApp; eauto. rewrite transform_blocks_isPrimApp; eauto. rewrite negb_or in H. move/andP: H => [] ncstr nprim. @@ -1126,7 +1126,7 @@ Proof. rewrite GlobalContextMap.lookup_constructor_pars_args_spec; destruct lookup_constructor_pars_args as [[[]] | ]; eauto. cbn. destruct chop. cbn. intros. - rewrite !orb_false_r. + rewrite !orb_false_r. destruct l1 using rev_case; cbn; eauto. rewrite mkApps_app; cbn; eauto. - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. diff --git a/erasure/theories/EDeps.v b/erasure/theories/EDeps.v index 924c746a9..6bee29a20 100644 --- a/erasure/theories/EDeps.v +++ b/erasure/theories/EDeps.v @@ -165,7 +165,7 @@ Proof. - depelim er. now constructor. - depelim er. - cbn. econstructor; eauto. + cbn. econstructor; eauto. - depelim er. econstructor; [easy|easy|easy|easy|easy|]. induction X; [easy|]. @@ -473,7 +473,7 @@ Proof. apply PCUICWeakeningEnv.lookup_env_Some_fresh in H as not_fresh. econstructor. - unfold PCUICAst.declared_constant in *; cbn. - inversion wfΣ; subst. destruct X0. + inversion wfΣ; subst. destruct X0. destruct (eqb_spec kn0 kn) as [<-|]; [congruence|]. eassumption. - unfold EGlobalEnv.declared_constant in *. cbn -[ReflectEq.eqb]. @@ -514,7 +514,7 @@ Proof. destruct d. split; eauto. red. cbn. cbn in *. destruct X0. destruct (eqb_spec (inductive_mind ind) kn). cbn in *. - subst. + subst. eapply PCUICWeakeningEnv.lookup_env_Some_fresh in kn_fresh. eauto. eapply H. exact H0. - econstructor; eauto. destruct H as [H H']. @@ -525,7 +525,7 @@ Proof. eapply PCUICWeakeningEnv.lookup_env_Some_fresh in H; eauto. contradiction. destruct H0 as [H0 H0']. split; eauto. red in H0 |- *. - inv wfΣ. destruct X0. cbn. change (eq_kername (inductive_mind p.1) kn) with (ReflectEq.eqb (inductive_mind p.1) kn). + inv wfΣ. destruct X0. cbn. change (eq_kername (inductive_mind p.1) kn) with (ReflectEq.eqb (inductive_mind p.1) kn). destruct (ReflectEq.eqb_spec (inductive_mind p.1) kn); auto. subst. destruct H as [H _]. eapply PCUICWeakeningEnv.lookup_env_Some_fresh in H. eauto. contradiction. @@ -637,7 +637,7 @@ Proof. eapply Forall2_All2 in Hprojs. eapply All2_nth_error_Some in Hprojs as [proj' [hnthp ?]]; eauto. econstructor; eauto. repeat split; eauto. repeat split; eauto. cbn. apply H0. now rewrite <- H3, hp. - + - constructor. apply inversion_Fix in wt as (?&?&?&?&?&?&?); eauto. clear -wf a0 X H Σer. @@ -671,7 +671,7 @@ Qed. Lemma Forall2_nth_error_left {A B} {P} {l : list A} {l' : list B} : Forall2 P l l' -> forall n x, nth_error l n = Some x -> exists x', nth_error l' n = Some x' /\ P x x'. -Proof. +Proof. induction 1; destruct n; simpl; auto; try discriminate. intros x' [= ->]. eexists; eauto. Qed. @@ -707,7 +707,7 @@ Proof. eapply (erases_extends ({| universes := univs; declarations := Σ |}, cst_universes cst')); eauto. cbn. 4:{ split; eauto; cbn; try reflexivity. eexists [_]; cbn; reflexivity. } constructor; auto. cbn. red in on_global_decl_d. rewrite E in on_global_decl_d. exact on_global_decl_d. - split; auto. + split; auto. * intros. eapply (erases_deps_cons {| universes := univs; declarations := Σ |} _ kn (PCUICEnvironment.ConstantDecl cst')); auto. unfold erases_constant_body in *. @@ -769,7 +769,7 @@ Proof. simpl in decli. rewrite eq_kername_refl in decli. intuition discriminate. * inv wf. inv X. destruct X1. specialize (IH _ (H0, X0) erg). - destruct decli as [decli ?]. + destruct decli as [decli ?]. simpl in decli |- *. unfold PCUICAst.declared_minductive, PCUICEnvironment.lookup_env in decli. simpl in decli. @@ -782,7 +782,7 @@ Proof. destruct decli'; red; split; eauto. red in d |- *. simpl. apply neqb in n. destruct eqb; cbn in n; try congruence. -Qed. +Qed. Lemma erases_global_erases_deps Σ Γ t T et Σ' : wf_ext Σ -> diff --git a/erasure/theories/EEnvMap.v b/erasure/theories/EEnvMap.v index 89872d71b..0071f8655 100644 --- a/erasure/theories/EEnvMap.v +++ b/erasure/theories/EEnvMap.v @@ -8,8 +8,8 @@ Lemma fresh_globals_cons_inv {Σ : global_context} {d} : EnvMap.fresh_globals (d Proof. intros H; now depelim H. Qed. Module GlobalContextMap. - Record t := - { global_decls :> global_declarations; + Record t := + { global_decls :> global_declarations; map : EnvMap.t global_decl; repr : EnvMap.repr global_decls map; wf : EnvMap.fresh_globals global_decls }. @@ -17,13 +17,13 @@ Module GlobalContextMap. Definition lookup_env Σ kn := EnvMap.lookup kn Σ.(map). Lemma lookup_env_spec (Σ : t) kn : lookup_env Σ kn = EGlobalEnv.lookup_env Σ kn. - Proof. + Proof. rewrite /lookup_env. rewrite (EnvMap.lookup_spec Σ.(global_decls)) //; apply Σ. Qed. Definition lookup_minductive Σ kn : option mutual_inductive_body := - decl <- lookup_env Σ kn;; + decl <- lookup_env Σ kn;; match decl with | ConstantDecl _ => None | InductiveDecl mdecl => ret mdecl @@ -39,7 +39,7 @@ Module GlobalContextMap. mdecl <- lookup_minductive Σ (inductive_mind kn) ;; idecl <- nth_error mdecl.(ind_bodies) (inductive_ind kn) ;; ret (mdecl, idecl). - + Lemma lookup_inductive_spec Σ kn : lookup_inductive Σ kn = EGlobalEnv.lookup_inductive Σ kn. Proof. rewrite /lookup_inductive /EGlobalEnv.lookup_inductive. @@ -49,7 +49,7 @@ Module GlobalContextMap. Definition lookup_constructor Σ kn c : option (mutual_inductive_body * one_inductive_body * constructor_body) := '(mdecl, idecl) <- lookup_inductive Σ kn ;; cdecl <- nth_error idecl.(ind_ctors) c ;; - ret (mdecl, idecl, cdecl). + ret (mdecl, idecl, cdecl). Lemma lookup_constructor_spec Σ kn : lookup_constructor Σ kn = EGlobalEnv.lookup_constructor Σ kn. Proof. @@ -68,8 +68,8 @@ Module GlobalContextMap. rewrite /lookup_projection /EGlobalEnv.lookup_projection. rewrite lookup_constructor_spec //. Qed. - - Definition lookup_inductive_pars Σ kn : option nat := + + Definition lookup_inductive_pars Σ kn : option nat := mdecl <- lookup_minductive Σ kn ;; ret mdecl.(ind_npars). @@ -79,7 +79,7 @@ Module GlobalContextMap. now rewrite lookup_minductive_spec. Qed. - Definition lookup_inductive_kind Σ kn : option recursivity_kind := + Definition lookup_inductive_kind Σ kn : option recursivity_kind := mdecl <- lookup_minductive Σ kn ;; ret mdecl.(ind_finite). @@ -92,8 +92,8 @@ Module GlobalContextMap. Definition inductive_isprop_and_pars Σ (ind : inductive) := '(mdecl, idecl) <- lookup_inductive Σ ind ;; ret (ind_propositional idecl, ind_npars mdecl). - - Lemma inductive_isprop_and_pars_spec Σ kn : + + Lemma inductive_isprop_and_pars_spec Σ kn : inductive_isprop_and_pars Σ kn = EGlobalEnv.inductive_isprop_and_pars Σ kn. Proof. rewrite /inductive_isprop_and_pars /EGlobalEnv.inductive_isprop_and_pars. @@ -103,8 +103,8 @@ Module GlobalContextMap. Definition constructor_isprop_pars_decl Σ (ind : inductive) (c : nat) := '(mdecl, idecl, cdecl) <- lookup_constructor Σ ind c ;; ret (ind_propositional idecl, ind_npars mdecl, cdecl). - - Lemma constructor_isprop_pars_decl_spec Σ kn : + + Lemma constructor_isprop_pars_decl_spec Σ kn : constructor_isprop_pars_decl Σ kn = EGlobalEnv.constructor_isprop_pars_decl Σ kn. Proof. rewrite /constructor_isprop_pars_decl /EGlobalEnv.constructor_isprop_pars_decl. @@ -114,8 +114,8 @@ Module GlobalContextMap. Definition lookup_constructor_pars_args Σ (ind : inductive) (c : nat) := '(mdecl, idecl, cdecl) <- lookup_constructor Σ ind c ;; ret (ind_npars mdecl, cstr_nargs cdecl). - - Lemma lookup_constructor_pars_args_spec Σ kn : + + Lemma lookup_constructor_pars_args_spec Σ kn : lookup_constructor_pars_args Σ kn = EGlobalEnv.lookup_constructor_pars_args Σ kn. Proof. rewrite /lookup_constructor_pars_args /EGlobalEnv.lookup_constructor_pars_args. diff --git a/erasure/theories/EEtaExpanded.v b/erasure/theories/EEtaExpanded.v index 78e399a4c..81c8a9080 100644 --- a/erasure/theories/EEtaExpanded.v +++ b/erasure/theories/EEtaExpanded.v @@ -37,8 +37,8 @@ Equations construct_viewc t : construct_view t := construct_viewc (tConstruct ind n block_args) := view_construct ind n block_args ; construct_viewc t := view_other t I. -Ltac toAll := - repeat match goal with +Ltac toAll := + repeat match goal with | [ H : forall x, In x ?l -> _ |- _ ] => eapply In_All in H end. @@ -46,13 +46,13 @@ Import ECSubst. Section isEtaExp. Context (Σ : global_declarations). - + Definition isEtaExp_app ind c k := match EGlobalEnv.lookup_constructor_pars_args Σ ind c with | Some (npars, nargs) => leb (npars + nargs) k | None => false end. - + Import TermSpineView. Definition is_nil {A} (l : list A) := match l with [] => true | _ => false end. @@ -63,7 +63,7 @@ Section isEtaExp. | tRel i => true | tEvar ev args => forallb_InP args (fun x H => isEtaExp x) | tLambda na M => isEtaExp M - | tApp u v napp nnil with construct_viewc u := + | tApp u v napp nnil with construct_viewc u := { | view_construct ind i block_args => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp x) && is_nil block_args | view_other _ _ => isEtaExp u && forallb_InP v (fun x H => isEtaExp x) } | tLetIn na b b' => isEtaExp b && isEtaExp b' @@ -80,15 +80,15 @@ Section isEtaExp. all:try lia. all:try apply (In_size); tea. all:try lia. - - now apply (In_size id size). + - now apply (In_size id size). - rewrite size_mkApps. eapply (In_size id size) in H. - change (fun x => size (id x)) with size in H. unfold id in *; cbn. + change (fun x => size (id x)) with size in H. unfold id in *; cbn. lia. - now eapply size_mkApps_f. - change (fun x => size (id x)) with size in H. eapply (In_size id size) in H. unfold id in H. - change (fun x => size x) with size in H. + change (fun x => size x) with size in H. pose proof (size_mkApps_l napp nnil). lia. - eapply (In_size snd size) in H. cbn in H; lia. Qed. @@ -105,7 +105,7 @@ Section isEtaExp. Lemma isEtaExp_mkApps_nonnil f v : ~~ isApp f -> v <> [] -> - isEtaExp (mkApps f v) = match construct_viewc f with + isEtaExp (mkApps f v) = match construct_viewc f with | view_construct ind i block_args => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args | view_other t discr => isEtaExp f && forallb isEtaExp v end. @@ -117,7 +117,7 @@ Section isEtaExp. Qed. Lemma isEtaExp_mkApps_napp f v : ~~ isApp f -> - isEtaExp (mkApps f v) = match construct_viewc f with + isEtaExp (mkApps f v) = match construct_viewc f with | view_construct ind i block_args => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args | view_other t discr => isEtaExp f && forallb isEtaExp v end. @@ -135,7 +135,7 @@ Section isEtaExp. Qed. - Lemma isEtaExp_mkApps f u : isEtaExp (mkApps f u) -> + Lemma isEtaExp_mkApps f u : isEtaExp (mkApps f u) -> let (hd, args) := decompose_app (mkApps f u) in match construct_viewc hd with | view_construct kn c block_args => isEtaExp_app Σ kn c #|args| && forallb isEtaExp args && is_nil block_args @@ -180,13 +180,13 @@ Section isEtaExp. eapply All_app_inv; eauto. Qed. - Lemma isEtaExp_tApp {f u} : isEtaExp (EAst.tApp f u) -> + Lemma isEtaExp_tApp {f u} : isEtaExp (EAst.tApp f u) -> let (hd, args) := decompose_app (EAst.tApp f u) in match construct_viewc hd with | view_construct kn c block_args => - args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ + args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ isEtaExp_app Σ kn c #|args| && forallb isEtaExp args && is_nil block_args - | view_other _ discr => + | view_other _ discr => [&& isEtaExp hd, forallb isEtaExp args, isEtaExp f & isEtaExp u] end. Proof using Type. @@ -257,10 +257,10 @@ Section WeakEtaExp. eapply All_app_inv; eauto. Qed. - Lemma etaExp_csubst a k b : + Lemma etaExp_csubst a k b : isEtaExp a -> isEtaExp b -> isEtaExp (ECSubst.csubst a k b). Proof using Type. - intros etaa. move b at bottom. + intros etaa. move b at bottom. funelim (isEtaExp b); cbn -[isEtaExp]; try simp_eta; eauto; try toAll; repeat solve_all. - intros. simp isEtaExp ; cbn. destruct Nat.compare => //. simp_eta in etaa. @@ -283,8 +283,8 @@ Section WeakEtaExp. specialize (H _ k etaa eu). eapply isEtaExp_mkApps_intro => //. solve_all. Qed. - - Lemma isEtaExp_substl s t : + + Lemma isEtaExp_substl s t : forallb isEtaExp s -> isEtaExp t -> isEtaExp (substl s t). Proof using Type. @@ -300,8 +300,8 @@ Section WeakEtaExp. unfold EGlobalEnv.iota_red. rewrite isEtaExp_substl // forallb_rev forallb_skipn //. Qed. - - Lemma isEtaExp_fix_subst mfix : + + Lemma isEtaExp_fix_subst mfix : forallb (fun d => isLambda (dbody d) && isEtaExp (dbody d)) mfix -> forallb isEtaExp (EGlobalEnv.fix_subst mfix). Proof using Type. @@ -311,7 +311,7 @@ Section WeakEtaExp. simp isEtaExp. solve_all. Qed. - Lemma isEtaExp_cofix_subst mfix : + Lemma isEtaExp_cofix_subst mfix : forallb (isEtaExp ∘ dbody) mfix -> forallb isEtaExp (EGlobalEnv.cofix_subst mfix). Proof using Type. @@ -320,8 +320,8 @@ Section WeakEtaExp. induction n; intros; simp_eta; constructor; auto. simp isEtaExp. solve_all. Qed. - - Lemma isEtaExp_cunfold_fix mfix idx n f : + + Lemma isEtaExp_cunfold_fix mfix idx n f : forallb (fun d => isLambda (dbody d) && isEtaExp (dbody d)) mfix -> EGlobalEnv.cunfold_fix mfix idx = Some (n, f) -> isEtaExp f. @@ -335,8 +335,8 @@ Section WeakEtaExp. eapply forallb_nth_error in heta; tea. erewrite heq in heta. now move/andP: heta. Qed. - - Lemma isEtaExp_cunfold_cofix mfix idx n f : + + Lemma isEtaExp_cunfold_cofix mfix idx n f : forallb (isEtaExp ∘ dbody) mfix -> EGlobalEnv.cunfold_cofix mfix idx = Some (n, f) -> isEtaExp f. @@ -353,7 +353,7 @@ Section WeakEtaExp. End WeakEtaExp. -Definition isEtaExp_constant_decl Σ cb := +Definition isEtaExp_constant_decl Σ cb := option_default (isEtaExp Σ) cb.(cst_body) true. Definition isEtaExp_decl Σ d := @@ -362,13 +362,13 @@ Definition isEtaExp_decl Σ d := | InductiveDecl idecl => true end. -Fixpoint isEtaExp_env (Σ : global_declarations) := - match Σ with +Fixpoint isEtaExp_env (Σ : global_declarations) := + match Σ with | [] => true | decl :: Σ => isEtaExp_decl Σ decl.2 && isEtaExp_env Σ end. -Lemma isEtaExp_lookup_ext {Σ} {kn d}: +Lemma isEtaExp_lookup_ext {Σ} {kn d}: isEtaExp_env Σ -> lookup_env Σ kn = Some d -> ∑ Σ', extends Σ' Σ × isEtaExp_decl Σ' d. @@ -389,7 +389,7 @@ Qed. Lemma isEtaExp_app_extends {efl : EEnvFlags} Σ Σ' ind k n : extends Σ Σ' -> - wf_glob Σ' -> + wf_glob Σ' -> isEtaExp_app Σ ind k n -> isEtaExp_app Σ' ind k n. Proof. @@ -402,7 +402,7 @@ Qed. From MetaCoq.Erasure Require Import ELiftSubst. -Lemma isEtaExp_extends {efl : EEnvFlags} Σ Σ' t : +Lemma isEtaExp_extends {efl : EEnvFlags} Σ Σ' t : extends Σ Σ' -> wf_glob Σ' -> isEtaExp Σ t -> @@ -423,7 +423,7 @@ Proof. - eapply In_All in H0. apply isEtaExp_mkApps_intro; eauto. solve_all. Qed. -Lemma isEtaExp_extends_decl {efl : EEnvFlags} {Σ Σ' t} : +Lemma isEtaExp_extends_decl {efl : EEnvFlags} {Σ Σ' t} : extends Σ Σ' -> wf_glob Σ' -> isEtaExp_decl Σ t -> @@ -434,7 +434,7 @@ Proof. now eapply isEtaExp_extends. Qed. -Lemma isEtaExp_lookup {efl : EEnvFlags} {Σ kn d}: +Lemma isEtaExp_lookup {efl : EEnvFlags} {Σ kn d}: isEtaExp_env Σ -> wf_glob Σ -> lookup_env Σ kn = Some d -> isEtaExp_decl Σ d. @@ -458,15 +458,15 @@ Inductive expanded : term -> Prop := | expanded_tLetIn (na : name) (def : term)(body : term) : expanded def -> expanded body -> expanded (tLetIn na def body) | expanded_mkApps (f : term) (args : list term) : ~ isConstruct f -> args <> [] -> expanded f -> Forall expanded args -> expanded (mkApps f args) | expanded_tConst (c : kername) : expanded (tConst c) -| expanded_tCase (ind : inductive) (pars : nat) (discr : term) (branches : list (list name × term)) : +| expanded_tCase (ind : inductive) (pars : nat) (discr : term) (branches : list (list name × term)) : expanded discr -> Forall (fun br => expanded br.2) branches -> expanded (tCase (ind, pars) discr branches) | expanded_tProj (proj : projection) (t : term) : expanded t -> expanded (tProj proj t) -| expanded_tFix (mfix : mfixpoint term) (idx : nat) : +| expanded_tFix (mfix : mfixpoint term) (idx : nat) : Forall (fun d => isLambda d.(dbody) /\ expanded d.(dbody)) mfix -> expanded (tFix mfix idx) | expanded_tCoFix (mfix : mfixpoint term) (idx : nat) : Forall (fun d => expanded d.(dbody)) mfix -> expanded (tCoFix mfix idx) | expanded_tConstruct_app ind idx mind idecl cdecl args : declared_constructor Σ (ind, idx) mind idecl cdecl -> - #|args| >= cstr_arity mind cdecl -> + #|args| >= cstr_arity mind cdecl -> Forall expanded args -> expanded (mkApps (tConstruct ind idx []) args) | expanded_tPrim p : expanded (tPrim p) @@ -511,7 +511,7 @@ forall (Σ : global_declarations) (P : term -> Prop), (forall p, P (tPrim p)) -> (P tBox) -> forall t : term, expanded Σ t -> P t. -Proof. +Proof. intros. revert t H13. fix f 2. intros t Hexp. destruct Hexp; eauto. @@ -527,24 +527,24 @@ Local Hint Constructors expanded : core. Definition expanded_constant_decl Σ (cb : constant_body) : Prop := on_Some_or_None (expanded Σ) cb.(cst_body). - + Definition expanded_decl Σ d := match d with | ConstantDecl cb => expanded_constant_decl Σ cb | InductiveDecl idecl => True end. - + Inductive expanded_global_declarations : forall (Σ : global_declarations), Prop := | expanded_global_nil : expanded_global_declarations [] -| expanded_global_cons decl Σ : expanded_global_declarations Σ -> +| expanded_global_cons decl Σ : expanded_global_declarations Σ -> expanded_decl Σ decl.2 -> expanded_global_declarations (decl :: Σ). Definition expanded_global_env := expanded_global_declarations. -Definition expanded_eprogram_cstrs (p : eprogram) := +Definition expanded_eprogram_cstrs (p : eprogram) := EEtaExpanded.isEtaExp_env p.1 && EEtaExpanded.isEtaExp p.1 p.2. -Definition expanded_eprogram_env_cstrs (p : eprogram_env) := +Definition expanded_eprogram_env_cstrs (p : eprogram_env) := let decls := p.1.(EEnvMap.GlobalContextMap.global_decls) in EEtaExpanded.isEtaExp_env decls && EEtaExpanded.isEtaExp decls p.2. @@ -585,13 +585,13 @@ Proof. destruct block_args; inv H0. eapply expanded_tConstruct_app with (args := []); eauto. - eapply andb_true_iff in H1 as []. destruct ind. econstructor; eauto. - rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2. + rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2. eapply In_All in H0. solve_all. - - econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. + - econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H. rtoProp; intuition auto; solve_all. all: move/andP: b. 2:{ now intros []. } intuition auto. - - econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. + - econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H. solve_all. - rtoProp. eapply In_All in H. rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2. @@ -612,7 +612,7 @@ Proof. induction 1; simp_eta; eauto. all: try now ( (try (eapply andb_true_iff; split; eauto)); - (try eapply forallb_Forall); + (try eapply forallb_Forall); eauto). - eapply isEtaExp_mkApps_intro; eauto. solve_all. - solve_all. now rewrite b H. @@ -647,13 +647,13 @@ Proof. rewrite mkApps_app in napp. now cbn in napp. Qed. -Ltac solve_discr_args := +Ltac solve_discr_args := match goal with [ H : ?t = mkApps ?f ?args |- _ ] => destruct (@solve_discr_args t f args eq_refl H) as [-> ->] || destruct (@solve_discr_args t f args eq_refl H) as [-> ?] end. -Lemma expanded_mkApps_expanded {Σ f args} : +Lemma expanded_mkApps_expanded {Σ f args} : expanded Σ f -> All (expanded Σ) args -> expanded Σ (mkApps f args). Proof. diff --git a/erasure/theories/EEtaExpandedFix.v b/erasure/theories/EEtaExpandedFix.v index 5975d992e..d6de01b76 100644 --- a/erasure/theories/EEtaExpandedFix.v +++ b/erasure/theories/EEtaExpandedFix.v @@ -10,7 +10,7 @@ Set Default Proof Using "Type*". Local Arguments eval : clear implicits. Lemma eval_app_cong_tApp fl Σ t v args res : - eval (switch_unguarded_fix fl) Σ t v -> + eval (switch_unguarded_fix fl) Σ t v -> eval (switch_unguarded_fix fl) Σ (tApp v args) res -> eval (switch_unguarded_fix fl) Σ (tApp t args) res. Proof. @@ -28,7 +28,7 @@ Section expanded. Variable Σ : global_declarations. Local Unset Elimination Schemes. - + Inductive expanded (Γ : list nat): term -> Prop := | expanded_tRel_app (n : nat) args m : nth_error Γ n = Some m -> forall Hle : m <= #|args|, Forall (expanded Γ) args -> expanded Γ (mkApps (tRel n) args) | expanded_tVar (id : ident) : expanded Γ (tVar id) @@ -37,12 +37,12 @@ Inductive expanded (Γ : list nat): term -> Prop := | expanded_tLetIn (na : name) (def : term) (body : term) : expanded Γ def (* -> expanded Γ def_ty *) -> expanded (0 :: Γ) body -> expanded Γ (tLetIn na def body) | expanded_mkApps (f : term) (args : list term) : negb (isConstruct f || isFix f || isRel f) -> expanded Γ f -> Forall (expanded Γ) args -> expanded Γ (mkApps f args) | expanded_tConst (c : kername) : expanded Γ (tConst c) -| expanded_tCase (ind : inductive) (pars : nat) (discr : term) (branches : list (list name × term)) : - expanded Γ discr -> - Forall (fun br => expanded (repeat 0 #|br.1| ++ Γ) br.2) branches -> +| expanded_tCase (ind : inductive) (pars : nat) (discr : term) (branches : list (list name × term)) : + expanded Γ discr -> + Forall (fun br => expanded (repeat 0 #|br.1| ++ Γ) br.2) branches -> expanded Γ (tCase (ind, pars) discr branches) | expanded_tProj (proj : projection) (t : term) : expanded Γ t -> expanded Γ (tProj proj t) -| expanded_tFix (mfix : mfixpoint term) (idx : nat) args d : +| expanded_tFix (mfix : mfixpoint term) (idx : nat) args d : Forall (fun d => isLambda d.(dbody) /\ let ctx := rev_map (fun d => 1 + d.(rarg)) mfix in expanded (ctx ++ Γ) d.(dbody)) mfix -> @@ -51,12 +51,12 @@ Inductive expanded (Γ : list nat): term -> Prop := nth_error mfix idx = Some d -> #|args| > d.(rarg) -> expanded Γ (mkApps (tFix mfix idx) args) -| expanded_tCoFix (mfix : mfixpoint term) (idx : nat) : +| expanded_tCoFix (mfix : mfixpoint term) (idx : nat) : Forall (fun d => expanded (repeat 0 #|mfix| ++ Γ) d.(dbody)) mfix -> expanded Γ (tCoFix mfix idx) | expanded_tConstruct_app ind idx mind idecl cdecl args : declared_constructor Σ (ind, idx) mind idecl cdecl -> - #|args| >= ind_npars mind + cdecl.(cstr_nargs) -> + #|args| >= ind_npars mind + cdecl.(cstr_nargs) -> Forall (expanded Γ) args -> expanded Γ (mkApps (tConstruct ind idx []) args) | expanded_tPrim p : expanded Γ (tPrim p) @@ -70,10 +70,10 @@ Lemma expanded_ind : nth_error Γ n = Some m -> (m ≤ #|args|) -> Forall (expanded Σ Γ) args - → Forall (P Γ) args + → Forall (P Γ) args → P Γ (mkApps (tRel n) args)) → (forall id : ident, forall Γ, P Γ (tVar id)) → - (forall (ev : nat) (args : list term) Γ, Forall (expanded Σ Γ) args → Forall (P Γ) args → P Γ (tEvar ev args)) + (forall (ev : nat) (args : list term) Γ, Forall (expanded Σ Γ) args → Forall (P Γ) args → P Γ (tEvar ev args)) → (∀ (Γ : list nat) (na : name) (body : term), expanded Σ (0 :: Γ) body → P (0 :: Γ) body → P Γ (tLambda na body)) → (∀ (Γ : list nat) (na : name) (def body : term), @@ -86,9 +86,9 @@ Lemma expanded_ind : → expanded Σ Γ f3 → P Γ f3 → Forall (expanded Σ Γ) args → Forall (P Γ) args → P Γ (mkApps f3 args)) → (∀ (Γ : list nat) (c : kername), P Γ (tConst c)) - → (∀ (Γ : list nat) (ind : inductive) - (pars : nat) (discr : term) (branches : - list + → (∀ (Γ : list nat) (ind : inductive) + (pars : nat) (discr : term) (branches : + list (list name × term)), expanded Σ Γ discr → P Γ discr @@ -101,8 +101,8 @@ Lemma expanded_ind : → P Γ (tCase (ind, pars) discr branches)) → (∀ (Γ : list nat) (proj : projection) (t : term), expanded Σ Γ t → P Γ t → P Γ (tProj proj t)) - → (∀ (Γ : list nat) (mfix : mfixpoint term) - (idx : nat) (args : list term) + → (∀ (Γ : list nat) (mfix : mfixpoint term) + (idx : nat) (args : list term) (d : def term), Forall (λ d0 : def term, @@ -122,14 +122,14 @@ Lemma expanded_ind : → (∀ (Γ : list nat) (mfix : mfixpoint term) (idx : nat), Forall (λ d : def term, - expanded Σ (repeat 0 #|mfix| ++ Γ) (dbody d)) mfix + expanded Σ (repeat 0 #|mfix| ++ Γ) (dbody d)) mfix → Forall (λ d : def term, - P (repeat 0 #|mfix| ++ Γ) (dbody d)) mfix + P (repeat 0 #|mfix| ++ Γ) (dbody d)) mfix → P Γ (tCoFix mfix idx)) - → (∀ (Γ : list nat) (ind : inductive) - (idx : nat) (mind : mutual_inductive_body) - (idecl : one_inductive_body) + → (∀ (Γ : list nat) (ind : inductive) + (idx : nat) (mind : mutual_inductive_body) + (idecl : one_inductive_body) cdecl (args : list term), declared_constructor Σ (ind, idx) mind idecl cdecl @@ -161,34 +161,34 @@ Qed. Definition expanded_constant_decl Σ (cb : constant_body) : Prop := on_Some_or_None (expanded Σ []) cb.(cst_body). - + Definition expanded_decl Σ d := match d with | ConstantDecl cb => expanded_constant_decl Σ cb | InductiveDecl idecl => True end. - + Inductive expanded_global_declarations : forall (Σ : global_declarations), Prop := | expanded_global_nil : expanded_global_declarations [] -| expanded_global_cons decl Σ : expanded_global_declarations Σ -> +| expanded_global_cons decl Σ : expanded_global_declarations Σ -> expanded_decl Σ decl.2 -> expanded_global_declarations (decl :: Σ). Definition expanded_global_env := expanded_global_declarations. -Definition expanded_eprogram (p : eprogram) := +Definition expanded_eprogram (p : eprogram) := expanded_global_env p.1 /\ expanded p.1 [] p.2. -Definition expanded_eprogram_env (p : eprogram_env) := +Definition expanded_eprogram_env (p : eprogram_env) := let decls := p.1.(EEnvMap.GlobalContextMap.global_decls) in expanded_global_env decls /\ expanded p.1 [] p.2. Local Hint Constructors expanded : core. -Arguments EWcbvEval.eval {wfl}. +Arguments EWcbvEval.eval {wfl}. Global Hint Rewrite repeat_length : len. -Lemma expanded_closed Σ Γ t : +Lemma expanded_closed Σ Γ t : expanded Σ Γ t -> ELiftSubst.closedn #|Γ| t. Proof. induction 1; cbn; eauto. @@ -243,9 +243,9 @@ Equations expanded_head_viewc t : expanded_head_view t := expanded_head_viewc (tFix mfix idx) := expanded_head_fix mfix idx ; expanded_head_viewc (tRel n) := expanded_head_rel n ; expanded_head_viewc t := expanded_head_other t I. - -Ltac toAll := - repeat match goal with + +Ltac toAll := + repeat match goal with | [ H : forall x, In x ?l -> _ |- _ ] => eapply In_All in H end. @@ -253,7 +253,7 @@ Import ECSubst. Section isEtaExp. Context (Σ : global_declarations). - + Definition isEtaExp_app ind c k := match lookup_constructor_pars_args Σ ind c with | Some (npars, nargs) => leb (npars + nargs) k @@ -264,8 +264,8 @@ Section isEtaExp. match nth_error mfix idx with | Some d => Nat.ltb d.(rarg) k | None => false - end. - + end. + Import TermSpineView. Definition is_nil {A} (l : list A) := match l with nil => true | _ => false end. @@ -276,12 +276,12 @@ Section isEtaExp. | tRel i => option_default (Nat.eqb 0) (nth_error Γ i) false | tEvar ev args => forallb_InP args (fun x H => isEtaExp Γ x) | tLambda na M => isEtaExp (0 :: Γ) M - | tApp u v napp nnil with expanded_head_viewc u := + | tApp u v napp nnil with expanded_head_viewc u := { | expanded_head_construct ind i block_args => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp Γ x) && is_nil block_args - | expanded_head_fix mfix idx => - isEtaExp_fixapp mfix idx (List.length v) && + | expanded_head_fix mfix idx => + isEtaExp_fixapp mfix idx (List.length v) && forallb_InP mfix (fun x H => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) && forallb_InP v (fun x H => isEtaExp Γ x) - | expanded_head_rel n => option_default (fun m => m <=? List.length v) (nth_error Γ n) false && forallb_InP v (fun x H => isEtaExp Γ x) + | expanded_head_rel n => option_default (fun m => m <=? List.length v) (nth_error Γ n) false && forallb_InP v (fun x H => isEtaExp Γ x) | expanded_head_other _ _ => isEtaExp Γ u && forallb_InP v (fun x H => isEtaExp Γ x) } | tLetIn na b b' => isEtaExp Γ b && isEtaExp (0 :: Γ) b' | tCase ind c brs => isEtaExp Γ c && forallb_InP brs (fun x H => isEtaExp (repeat 0 #|x.1| ++ Γ) x.2) @@ -297,27 +297,27 @@ Section isEtaExp. all:try lia. all:try apply (In_size); tea. all:try lia. - - now apply (In_size id size). + - now apply (In_size id size). - rewrite size_mkApps. cbn. apply (In_size id size) in H. unfold id in H. change (fun x => size x) with size in H. lia. - rewrite size_mkApps. - apply (In_size id (fun d => size d.(dbody))) in H. unfold id in H. + apply (In_size id (fun d => size d.(dbody))) in H. unfold id in H. change (fun x => size x) with size in H. cbn. lia. - rewrite size_mkApps. - apply (In_size id size) in H. unfold id in H. + apply (In_size id size) in H. unfold id in H. change (fun x => size x) with size in H. cbn. lia. - rewrite size_mkApps. - apply (In_size id size) in H. unfold id in H. + apply (In_size id size) in H. unfold id in H. change (fun x => size x) with size in H. cbn. lia. - now eapply size_mkApps_f. - change (fun x => size (id x)) with size in H. eapply (In_size id size) in H. unfold id in H. - change (fun x => size x) with size in H. + change (fun x => size x) with size in H. pose proof (size_mkApps_l napp nnil). lia. - eapply (In_size snd size) in H. cbn in H; lia. Qed. - + Lemma isEtaExp_app_mon ind c i i' : i <= i' -> isEtaExp_app ind c i -> isEtaExp_app ind c i'. Proof. intros le. @@ -330,9 +330,9 @@ Section isEtaExp. Lemma isEtaExp_mkApps_nonnil Γ f v : ~~ isApp f -> v <> [] -> - isEtaExp Γ (mkApps f v) = match expanded_head_viewc f with + isEtaExp Γ (mkApps f v) = match expanded_head_viewc f with | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args - | expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|v| && + | expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|v| && forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v | expanded_head_rel n => option_default (fun m => m <=? List.length v) (nth_error Γ n) false && forallb (fun x => isEtaExp Γ x) v | expanded_head_other t discr => isEtaExp Γ f && forallb (isEtaExp Γ) v @@ -348,12 +348,12 @@ Section isEtaExp. Ltac simp_eta := simp isEtaExp; rewrite -?isEtaExp_equation_1. Definition is_cons {A} (l : list A) := match l with [] => false | _ => true end. - - Lemma isEtaExp_mkApps Γ f v : ~~ isApp f -> - isEtaExp Γ (mkApps f v) = match expanded_head_viewc f with + + Lemma isEtaExp_mkApps Γ f v : ~~ isApp f -> + isEtaExp Γ (mkApps f v) = match expanded_head_viewc f with | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args - | expanded_head_fix mfix idx => - isEtaExp_fixapp mfix idx #|v| && + | expanded_head_fix mfix idx => + isEtaExp_fixapp mfix idx #|v| && forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v | expanded_head_rel n => option_default (fun m => m <=? List.length v) (nth_error Γ n) false && forallb (fun x => isEtaExp Γ x) v | expanded_head_other t discr => isEtaExp Γ f && forallb (isEtaExp Γ) v @@ -373,7 +373,7 @@ Section isEtaExp. Proof. now rewrite isEtaExp_mkApps. Qed. - + Lemma isEtaExp_mkApps_intro Γ t l : isEtaExp Γ t -> All (isEtaExp Γ) l -> isEtaExp Γ (mkApps t l). Proof. revert t Γ; induction l using rev_ind; auto. @@ -387,7 +387,7 @@ Section isEtaExp. destruct expanded_head_viewc. + cbn. len. rtoProp; repeat solve_all; cbn in et; rtoProp; eauto. rename H0 into et. simp isEtaExp in et. - eapply isEtaExp_app_mon; tea; lia. + eapply isEtaExp_app_mon; tea; lia. eapply All_app_inv; eauto. + cbn in *; congruence. + simp_eta in et. @@ -395,7 +395,7 @@ Section isEtaExp. eapply Nat.eqb_eq in et. rewrite <- et. rtoProp. split. cbn. eauto. solve_all. eapply All_app_inv; solve_all. - + rewrite et forallb_app /=. rtoProp; repeat solve_all. + + rewrite et forallb_app /=. rtoProp; repeat solve_all. - rewrite isEtaExp_mkApps in et => //. destruct expanded_head_viewc. + rewrite -mkApps_app. rewrite isEtaExp_Constructor. @@ -407,7 +407,7 @@ Section isEtaExp. rewrite /isEtaExp_fixapp in et |- *. rtoProp; repeat split. * destruct nth_error; try congruence. eapply Nat.ltb_lt. eapply Nat.ltb_lt in H0. - cbn in H0. len. + cbn in H0. len. * solve_all. * solve_all. eapply All_app_inv; solve_all. eapply All_app_inv; solve_all. + rewrite -mkApps_app. rewrite isEtaExp_mkApps //. @@ -438,7 +438,7 @@ Section isEtaExp. - rewrite isEtaExp_mkApps => //. rewrite Heq. rtoProp; repeat solve_all. Qed. - Lemma isEtaExp_closed Γ t : + Lemma isEtaExp_closed Γ t : isEtaExp Γ t -> closedn #|Γ| t. Proof. funelim (isEtaExp Γ t); simp_eta; cbn [closedn]; @@ -453,7 +453,7 @@ Section isEtaExp. - destruct nth_error eqn:Hn; cbn in H1; try easy. eapply nth_error_Some_length in Hn. now eapply Nat.ltb_lt. Qed. - Lemma etaExp_csubst' a k b n Γ Δ : + Lemma etaExp_csubst' a k b n Γ Δ : #|Γ| = k -> isEtaExp [] a -> isEtaExp (Γ ++ [n] ++ Δ) b -> isEtaExp (Γ ++ Δ) (ECSubst.csubst a k b). Proof. @@ -495,7 +495,7 @@ Section isEtaExp. now eapply isLambda_csubst. rewrite app_assoc. eapply a0; len; eauto. rewrite app_assoc. do 2 f_equal. - rewrite !rev_map_spec. f_equal. rewrite map_map. now eapply map_ext. + rewrite !rev_map_spec. f_equal. rewrite map_map. now eapply map_ext. + solve_all. - rewrite csubst_mkApps /=. rtoProp. destruct (Nat.compare_spec #|Γ0| n) => //; simp_eta. + eapply isEtaExp_mkApps_intro => //. 2: solve_all. @@ -510,24 +510,24 @@ Section isEtaExp. - rewrite csubst_mkApps /=. move/andP: H2 => [] eu ev. eapply isEtaExp_mkApps_intro => //. 2: solve_all. - eauto. + eauto. Qed. - Lemma etaExp_csubst a b n : - isEtaExp []a -> isEtaExp [n] b -> isEtaExp [] (ECSubst.csubst a 0 b). + Lemma etaExp_csubst a b n : + isEtaExp []a -> isEtaExp [n] b -> isEtaExp [] (ECSubst.csubst a 0 b). Proof. intros. eapply etaExp_csubst' with (Γ := []); eauto. Qed. - Lemma etaExp_fixsubst k b Γ Δ mfix idx d : + Lemma etaExp_fixsubst k b Γ Δ mfix idx d : #|Γ| = k -> nth_error mfix idx = Some d -> closed (EAst.tFix mfix idx) -> forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix) x.(dbody)) mfix -> isEtaExp (Γ ++ [1 + d.(EAst.rarg)] ++ Δ) b -> isEtaExp (Γ ++ Δ) (ECSubst.csubst (EAst.tFix mfix idx) k b). Proof using Type*. - intros Hk Hnth Hcl. + intros Hk Hnth Hcl. remember (Γ ++ [1 + d.(EAst.rarg)] ++ Δ)%list as Γ_. funelim (isEtaExp Γ_ b); try simp_eta; eauto; try fold csubst; try toAll; try solve_all; subst. @@ -540,7 +540,7 @@ Section isEtaExp. - intros. eapply forallb_All in H1; eapply All_mix in H; tea. eapply All_forallb, All_map, All_impl; tea; cbv beta. intros x Hx. eapply Hx; eauto. apply Hx. - - eapply H with (Γ := 0 :: Γ0); cbn -[isEtaExp]; eauto. + - eapply H with (Γ := 0 :: Γ0); cbn -[isEtaExp]; eauto. - solve_all. move/andP: H2 => [] etab etab'. simp_eta. apply/andP. split; eauto. eapply H; eauto. solve_all. @@ -558,7 +558,7 @@ Section isEtaExp. rewrite csubst_mkApps /=. rewrite isEtaExp_Constructor. solve_all. rewrite map_length. rtoProp; solve_all. - rewrite forallb_map. + rewrite forallb_map. eapply All_forallb. clear Heq0 Heq. eapply All_impl; tea; cbv beta. intros x Hx. @@ -577,7 +577,7 @@ Section isEtaExp. { cbn in Hcl. solve_all. rewrite Nat.add_0_r in a0. eauto. } cbn. rewrite app_assoc. do 2 f_equal. rewrite !rev_map_spec. f_equal. rewrite map_map. now eapply map_ext. - solve_all. + solve_all. + eapply forallb_All in ev; eapply All_mix in H0; tea. eapply All_forallb, All_map, All_impl; tea; cbv beta. intros x Hx. eapply Hx; eauto. solve_all. apply Hx. @@ -587,7 +587,7 @@ Section isEtaExp. * unfold isEtaExp_fixapp. rewrite Hnth. len. subst. rewrite nth_error_app2 in H1; try lia. rewrite minus_diag in H1. cbn in H1. eapply Nat.ltb_lt. - eapply Nat.leb_le in H1. lia. + eapply Nat.leb_le in H1. lia. * cbn in Hcl. solve_all. rtoProp; intuition auto. now eapply expanded_weakening. * eapply forallb_All in H2. eapply All_mix in H; tea. @@ -596,7 +596,7 @@ Section isEtaExp. + rewrite isEtaExp_mkApps; eauto. cbn [expanded_head_viewc]. rtoProp. intros. split. 2:{ - eapply forallb_All in H2; eapply All_mix in H; tea; clear H2. + eapply forallb_All in H2; eapply All_mix in H; tea; clear H2. eapply All_forallb, All_map, All_impl; tea; cbv beta. intros x Hx. eapply Hx; eauto. apply Hx. } rewrite !nth_error_app2 in H1 |- *; cbn; try lia. len. @@ -604,20 +604,20 @@ Section isEtaExp. destruct n; cbn; lia. + rewrite isEtaExp_mkApps; eauto. cbn [expanded_head_viewc]. intros. rtoProp. split. 2:{ - eapply forallb_All in H2; eapply All_mix in H; tea; clear H2. + eapply forallb_All in H2; eapply All_mix in H; tea; clear H2. eapply All_forallb, All_map, All_impl; tea; cbv beta. intros x Hx. eapply Hx; eauto. apply Hx. } len. now rewrite !nth_error_app1 in H1 |- *; try lia. - intros. rtoProp. rewrite csubst_mkApps /=. eapply isEtaExp_mkApps_intro => //. - 2:{ eapply forallb_All in H3; eapply All_mix in H0; tea; clear H3. + 2:{ eapply forallb_All in H3; eapply All_mix in H0; tea; clear H3. eapply All_map, All_impl; tea; cbv beta. intros x Hx. eapply Hx; eauto. apply Hx. } eapply H; eauto. Qed. - - Lemma isEtaExp_substl Γ Δ s t : + + Lemma isEtaExp_substl Γ Δ s t : #|Γ| = #|s| -> forallb (isEtaExp []) s -> isEtaExp (Γ ++ Δ) t -> isEtaExp Δ (substl s t). @@ -629,7 +629,7 @@ Section isEtaExp. eapply IHs; eauto. eapply etaExp_csubst' with (Γ := []); eauto. Qed. - Lemma isEtaExp_fixsubstl Δ mfix t : + Lemma isEtaExp_fixsubstl Δ mfix t : forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix) x.(dbody)) mfix -> isEtaExp ((rev_map (S ∘ rarg) mfix) ++ Δ) t -> @@ -637,22 +637,22 @@ Section isEtaExp. Proof using Type*. intros Hall Heta. assert (Hcl : closed (EAst.tFix mfix 0) ). { cbn. solve_all. rtoProp; intuition auto. eapply isEtaExp_closed in H0. revert H0. now len. } - revert Hcl Hall Heta. + revert Hcl Hall Heta. intros Hcl Hall Heta. cbn in Hcl. solve_all. unfold fix_subst. revert Hall Heta. - + generalize (@eq_refl _ mfix). setoid_rewrite <- app_nil_r at 1. generalize ((@nil (EAst.def EAst.term))). generalize (mfix) at 1 6 8. - + intros mfix0. revert mfix Δ t. induction mfix0 using rev_ind; intros. - cbn -[isEtaExp] in *. eauto. - cbn -[isEtaExp] in *. rewrite app_length Nat.add_comm. cbn -[substl isEtaExp]. - eapply IHmfix0. + eapply IHmfix0. + subst. now rewrite <- app_assoc. + solve_all. + eapply etaExp_fixsubst with (Γ := []); eauto. @@ -676,27 +676,27 @@ Section isEtaExp. - shelve. - solve_all. eapply All_skipn. solve_all. - rewrite app_nil_r. eauto. - Unshelve. len. now rewrite List.skipn_length. + Unshelve. len. now rewrite List.skipn_length. Qed. - + (* - Lemma isEtaExp_fix_subst mfix : + Lemma isEtaExp_fix_subst mfix : forallb (isEtaExp (repeat 0 #|mfix|) ∘ dbody) mfix -> forallb (isEtaExp []) (EGlobalEnv.fix_subst mfix). Proof. unfold EGlobalEnv.fix_subst. - generalize (@eq_refl _ #|mfix|). + generalize (@eq_refl _ #|mfix|). generalize #|mfix| at 1 3 4. intros. solve_all. revert n H H0. induction n; intros; simp_eta; constructor; auto. + simp_eta. - simp isEtaExp. solve_all. - Qed. + simp isEtaExp. solve_all. + Qed. *) - - Lemma isEtaExp_cofix_subst mfix : + + Lemma isEtaExp_cofix_subst mfix : forallb (isEtaExp (repeat 0 #|mfix|) ∘ dbody) mfix -> forallb (isEtaExp []) (EGlobalEnv.cofix_subst mfix). Proof. @@ -705,9 +705,9 @@ Section isEtaExp. unfold cofix_subst. generalize #|mfix|. intros n. solve_all. induction n. + econstructor. + econstructor. simp_eta. solve_all. now rewrite app_nil_r. solve_all. - Qed. - - Lemma isEtaExp_cunfold_fix mfix idx n f : + Qed. + + Lemma isEtaExp_cunfold_fix mfix idx n f : forallb (fun d => isLambda d.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix) d.(dbody)) mfix -> EGlobalEnv.cunfold_fix mfix idx = Some (n, f) -> isEtaExp [] f. @@ -721,8 +721,8 @@ Section isEtaExp. - rewrite app_nil_r. solve_all. eapply All_nth_error in heta; eauto. now move/andP: heta. Qed. - - Lemma isEtaExp_cunfold_cofix mfix idx n f : + + Lemma isEtaExp_cunfold_cofix mfix idx n f : forallb (isEtaExp (repeat 0 #|mfix|) ∘ dbody) mfix -> EGlobalEnv.cunfold_cofix mfix idx = Some (n, f) -> isEtaExp [] f. @@ -738,15 +738,15 @@ Section isEtaExp. simp_eta. solve_all. now rewrite app_nil_r. Qed. - Lemma isEtaExp_tApp Γ f u : isEtaExp Γ (mkApps f u) -> + Lemma isEtaExp_tApp Γ f u : isEtaExp Γ (mkApps f u) -> let (hd, v) := decompose_app (mkApps f u) in match expanded_head_viewc hd with | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args - | expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|v| && + | expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|v| && forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v | expanded_head_rel n => (option_default (fun m => m <=? List.length v) (nth_error Γ n) false) && forallb (fun x => isEtaExp Γ x) v | expanded_head_other t discr => isEtaExp Γ hd && forallb (isEtaExp Γ) v - end. (* + end. (* | expanded_head_construct kn c => isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ) args | expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|args| && forallb mfix (fun x => isEtaExp Σ x.(dbody)) && forallb (isEtaExp Σ) args | expanded_head_rel n => (nth n Γ 0 <=? List.length v) && forallb (fun x => isEtaExp Γ x) v @@ -803,16 +803,16 @@ Proof. destruct block_args; cbn in *; eauto. eapply expanded_tConstruct_app with (args := []); eauto. - eapply andb_true_iff in H1 as []. destruct ind. econstructor; eauto. - rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2. + rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2. eapply In_All in H0. solve_all. - - econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. + - econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H. solve_all. - rtoProp. eapply In_All in H. rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2. eapply isEtaExp_app_expanded in H0 as (? & ? & ? & ? & ?). destruct block_args; cbn in *; eauto. eapply expanded_tConstruct_app; eauto. solve_all. - - rtoProp. rewrite forallb_InP_spec in H2. rewrite forallb_InP_spec in H3. eapply In_All in H. eapply In_All in H0. + - rtoProp. rewrite forallb_InP_spec in H2. rewrite forallb_InP_spec in H3. eapply In_All in H. eapply In_All in H0. unfold isEtaExp_fixapp in H1. destruct nth_error eqn:E; try congruence. eapply expanded_tFix. all: try now solve_all. solve_all; rtoProp; intuition auto. @@ -834,11 +834,11 @@ Proof. induction 1; simp_eta; eauto. all: try now ( (try (eapply andb_true_iff; split; eauto)); - (try eapply forallb_Forall); + (try eapply forallb_Forall); eauto). - rewrite isEtaExp_mkApps //. cbn [expanded_head_viewc]. rtoProp. split. 2: solve_all. rewrite H. now eapply Nat.leb_le. - - eapply isEtaExp_mkApps_intro; eauto. solve_all. + - eapply isEtaExp_mkApps_intro; eauto. solve_all. - rewrite isEtaExp_mkApps //. cbn [expanded_head_viewc]. rtoProp. repeat split. + unfold isEtaExp_fixapp. rewrite H4. eapply Nat.ltb_lt. lia. + solve_all; rtoProp; intuition auto. @@ -848,7 +848,7 @@ Proof. eapply expanded_isEtaExp_app_; eauto. Qed. -Definition isEtaExp_constant_decl Σ cb := +Definition isEtaExp_constant_decl Σ cb := option_default (isEtaExp Σ []) cb.(cst_body) true. Definition isEtaExp_decl Σ d := @@ -857,8 +857,8 @@ Definition isEtaExp_decl Σ d := | InductiveDecl idecl => true end. -Fixpoint isEtaExp_env (Σ : global_declarations) := - match Σ with +Fixpoint isEtaExp_env (Σ : global_declarations) := + match Σ with | [] => true | decl :: Σ => isEtaExp_decl Σ decl.2 && isEtaExp_env Σ end. @@ -870,7 +870,7 @@ Proof. - now rewrite IHl /= andb_assoc. Qed. -Lemma lookup_inductive_pars_constructor_pars_args Σ {ind n pars args} : +Lemma lookup_inductive_pars_constructor_pars_args Σ {ind n pars args} : lookup_constructor_pars_args Σ ind n = Some (pars, args) -> lookup_inductive_pars Σ (inductive_mind ind) = Some pars. Proof. @@ -881,19 +881,19 @@ Qed. Arguments isEtaExp : simpl never. -Lemma isEtaExp_tApp' {Σ} {Γ} {f u} : isEtaExp Σ Γ (tApp f u) -> +Lemma isEtaExp_tApp' {Σ} {Γ} {f u} : isEtaExp Σ Γ (tApp f u) -> let (hd, args) := decompose_app (tApp f u) in match expanded_head_viewc hd with | expanded_head_construct kn c block_args => - args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ + args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ Γ) args && is_nil block_args - | expanded_head_fix mfix idx => - args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ + | expanded_head_fix mfix idx => + args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ isEtaExp_fixapp mfix idx #|args| && forallb (fun d => isLambda d.(dbody) && isEtaExp Σ (rev_map (fun d => 1 + d.(rarg)) mfix ++ Γ) d.(dbody)) mfix && forallb (isEtaExp Σ Γ) args - | expanded_head_rel n => - args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ + | expanded_head_rel n => + args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ option_default (fun m => m <=? List.length args) (nth_error Γ n) false && forallb (fun x => isEtaExp Σ Γ x) args - | expanded_head_other _ discr => + | expanded_head_other _ discr => [&& isEtaExp Σ Γ hd, forallb (isEtaExp Σ Γ) args, isEtaExp Σ Γ f & isEtaExp Σ Γ u] end. Proof. @@ -942,7 +942,7 @@ Proof. now rewrite remove_last_app. Qed. -Lemma isEtaExp_lookup_ext {Σ} {kn d}: +Lemma isEtaExp_lookup_ext {Σ} {kn d}: isEtaExp_env Σ -> lookup_env Σ kn = Some d -> ∑ Σ', extends Σ' Σ × isEtaExp_decl Σ' d. @@ -962,7 +962,7 @@ Qed. Lemma isEtaExp_app_extends {efl : EEnvFlags} Σ Σ' ind k n : extends Σ Σ' -> - wf_glob Σ' -> + wf_glob Σ' -> isEtaExp_app Σ ind k n -> isEtaExp_app Σ' ind k n. Proof. @@ -973,7 +973,7 @@ Proof. rewrite (extends_lookup wf ext hl) /= //. Qed. -Lemma isEtaExp_extends {efl : EEnvFlags} Σ Σ' Γ t : +Lemma isEtaExp_extends {efl : EEnvFlags} Σ Σ' Γ t : extends Σ Σ' -> wf_glob Σ' -> isEtaExp Σ Γ t -> @@ -998,7 +998,7 @@ Proof. - eapply In_All in H0. apply isEtaExp_mkApps_intro; eauto. solve_all. Qed. -Lemma isEtaExp_extends_decl {efl : EEnvFlags} Σ Σ' t : +Lemma isEtaExp_extends_decl {efl : EEnvFlags} Σ Σ' t : extends Σ Σ' -> wf_glob Σ' -> isEtaExp_decl Σ t -> @@ -1009,7 +1009,7 @@ Proof. now eapply isEtaExp_extends. Qed. -Lemma isEtaExp_lookup {efl : EEnvFlags} {Σ kn d}: +Lemma isEtaExp_lookup {efl : EEnvFlags} {Σ kn d}: isEtaExp_env Σ -> wf_glob Σ -> lookup_env Σ kn = Some d -> isEtaExp_decl Σ d. @@ -1021,16 +1021,16 @@ Qed. Arguments lookup_inductive_pars_constructor_pars_args {Σ ind n pars args}. -Lemma eval_etaexp {fl : WcbvFlags} {efl : EEnvFlags} {wcon : with_constructor_as_block = false} {Σ a a'} : +Lemma eval_etaexp {fl : WcbvFlags} {efl : EEnvFlags} {wcon : with_constructor_as_block = false} {Σ a a'} : isEtaExp_env Σ -> wf_glob Σ -> eval Σ a a' -> isEtaExp Σ [] a -> isEtaExp Σ [] a'. Proof. intros etaΣ wfΣ. - induction 1 as [ | ? ? ? ? ? ? ? ? IHs | | | | | ? ? ? ? ? ? ? ? ? ? ? IHs | ? ? ? ? ? ? ? ? ? ? ? IHs + induction 1 as [ | ? ? ? ? ? ? ? ? IHs | | | | | ? ? ? ? ? ? ? ? ? ? ? IHs | ? ? ? ? ? ? ? ? ? ? ? IHs | ? ? ? ? ? ? ? ? ? ? IHs | | | | | | | | | | ] using eval_mkApps_rect; try now congruence. all:try simp isEtaExp; rewrite -!isEtaExp_equation_1 => //. - 6:{ + 6:{ move/isEtaExp_tApp'. destruct decompose_app eqn:da. destruct expanded_head_viewc eqn:vc. @@ -1066,7 +1066,7 @@ Proof. rewrite nth_error_nil in H6. easy. * move/and4P => [] etat etal etaf etaa. pose proof (mkApps_app (tFix mfix idx) argsv [av]). cbn in H3. rewrite <- H3. clear H3. - specialize (IHeval1 etaf). + specialize (IHeval1 etaf). rewrite !isEtaExp_mkApps in IHeval1 |- * => //. cbn [expanded_head_viewc] in *. rtoProp. repeat split; solve_all. -- unfold isEtaExp_fixapp, cunfold_fix in *. destruct nth_error; invs H1. @@ -1082,7 +1082,7 @@ Proof. * move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel. subst. eapply IHeval3. - + pose proof (mkApps_app fn argsv [av]). cbn in H3. rewrite <- H3. clear H3. @@ -1090,7 +1090,7 @@ Proof. specialize eval_mkApps_tFix_inv_size with (Heval := H); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto. -- solve_all. eapply (f_equal decompose_app) in Heq. rewrite !decompose_app_mkApps in Heq => //. invs Heq. sq. - eapply isEtaExp_mkApps_intro. + eapply isEtaExp_mkApps_intro. eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H5. eapply All_app_inv. 2: repeat econstructor; eauto. @@ -1106,7 +1106,7 @@ Proof. destruct nth_error; try easy. invs H5. eapply Nat.ltb_lt. lia. rewrite isEtaExp_mkApps in IHeval1 => //. cbn [expanded_head_viewc] in IHeval1. rtoProp. - eapply isEtaExp_mkApps_intro. + eapply isEtaExp_mkApps_intro. eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H10. eapply All_app_inv. 2: repeat econstructor; eauto. @@ -1115,10 +1115,10 @@ Proof. rewrite nth_error_nil in H6. easy. * move/and4P => [] etat etal etaf etaa. eapply IHeval3. pose proof (mkApps_app fn argsv [av]). cbn in H3. rewrite <- H3. clear H3. - specialize (IHeval1 etaf). + specialize (IHeval1 etaf). rewrite !isEtaExp_mkApps in IHeval1 => //. cbn [expanded_head_viewc] in *. rtoProp. - eapply isEtaExp_mkApps_intro. + eapply isEtaExp_mkApps_intro. eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H6. eapply All_app_inv. 2: repeat econstructor; eauto. @@ -1134,11 +1134,11 @@ Proof. rewrite !negb_or in i. rtoProp; intuition auto. now cbn in H3. * move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel. subst. - + assert (isEtaExp Σ [] a). { rewrite ha. eapply Forall_last; solve_all. } destruct with_guarded_fix eqn:guarded. { - + specialize eval_mkApps_tFix_inv_size with (Heval := H); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto. -- subst. rewrite isFixApp_mkApps in i => //. destruct EAst.isLambda; easy. -- eapply (isEtaExp_mkApps_intro _ _ f' [a']); eauto. @@ -1167,7 +1167,7 @@ Proof. } * intros (? & ? & ? & ?). rtoProp. solve_all. rewrite nth_error_nil in H5. easy. - * move/and4P => [] etat etal etaf etaa. + * move/and4P => [] etat etal etaf etaa. eapply (isEtaExp_mkApps_intro _ _ f' [a']); eauto. } 10:{ @@ -1238,7 +1238,7 @@ Proof. destruct with_guarded_fix eqn:guarded. { - specialize eval_mkApps_tFix_inv_size with (Heval := H); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto. + specialize eval_mkApps_tFix_inv_size with (Heval := H); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto. -- solve_discr. -- eapply IHeval3. eapply etaExp_csubst. eapply IHeval2. rewrite H3. eapply Forall_last; solve_all. @@ -1253,8 +1253,8 @@ Proof. { specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H); intros Hinv; destruct Hinv as [[Heq Heq'] | (a_ & a_' & args' & argsv & Heq & Hall & n & fn & Hunf & Haa' & Hsz & Hev & Hsz')]; eauto; try congruence. eapply IHeval3. eapply etaExp_csubst. - - eapply IHeval2. rewrite H3. eapply Forall_last. eauto. solve_all. + + eapply IHeval2. rewrite H3. eapply Forall_last. eauto. solve_all. assert (isEtaExp Σ [] (mkApps (tApp fn a_') argsv) -> isEtaExp Σ [] (EAst.tLambda na b)) as IH. { unshelve eapply IHs; eauto. } @@ -1266,14 +1266,14 @@ Proof. setoid_rewrite Heq in isel. invs isel. eauto. ++ eapply All_Forall in H6 as isel. eapply Forall_firstn in isel. unfold remove_last in Heq. setoid_rewrite Heq in isel. eapply Forall_All in isel. invs isel. solve_all. subst; eauto. - destruct b1. unshelve eapply IHs. 2: eauto. lia. eauto. + destruct b1. unshelve eapply IHs. 2: eauto. lia. eauto. } - + * solve_all. rtoProp. solve_all. rewrite nth_error_nil in H5; easy. - * move/and4P => [] etat etal etaf etaa. simp_eta in IHeval1. eapply IHeval3, etaExp_csubst; eauto. + * move/and4P => [] etat etal etaf etaa. simp_eta in IHeval1. eapply IHeval3, etaExp_csubst; eauto. } - - rtoProp. solve_all. eapply IHeval2, etaExp_csubst; eauto. + - rtoProp. solve_all. eapply IHeval2, etaExp_csubst; eauto. - rtoProp; intuition eauto. eapply IHeval2. rewrite /iota_red. @@ -1296,10 +1296,10 @@ Proof. move: H H0. rewrite hf => H H0. clear H0; eapply (eval_mkApps_Construct_inv _ _ _ _ _ wcon) in H as [? []]; solve_discr. * solve_all. rtoProp. solve_all. subst. - specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H); intros Hinv; + specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H); intros Hinv; destruct Hinv as [[Heq Heq'] | (a_ & a_' & args' & argsv & Heq & Hall & n & fn_ & Hunf & Hav & Hsza & Hev & Hsz)]; eauto; try congruence. - -- invs Heq'. eapply IHeval1. + -- invs Heq'. eapply IHeval1. eapply (isEtaExp_mkApps_intro _ _ fn [av]); eauto. 2: econstructor; [ | econstructor]. ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H7. ++ eapply (H2 _ _ H1). lia. rewrite H6. eapply Forall_last. 2: solve_all. eauto. @@ -1307,7 +1307,7 @@ Proof. { intros; eapply H0; eauto. } exfalso. forward H7. - eapply isEtaExp_mkApps_intro. + eapply isEtaExp_mkApps_intro. eapply (isEtaExp_mkApps_intro _ _ fn_ [a_']); eauto. 2: econstructor; [ | econstructor]. ** eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H10. ** solve_all. eapply All_firstn in H9 as isel. unfold remove_last in Heq. eapply All_Forall in isel. @@ -1406,7 +1406,7 @@ Proof. split. eapply All2_app => //. rewrite -H3. eauto. destruct s. * destruct p; solve_discr. noconf H2. - left. split. + left. split. unfold isStuckFix'; rewrite e1. len. eapply Nat.leb_le. lia. now rewrite -[tApp _ _](mkApps_app _ _ [av]). * right. len. eapply isEtaExp_fixapp_mon; tea. lia. @@ -1417,7 +1417,7 @@ Proof. split. eapply All2_app => //. rewrite -H3. eauto. destruct s. * destruct p. solve_discr. - * right. len. eapply isEtaExp_fixapp_mon; tea. lia. + * right. len. eapply isEtaExp_fixapp_mon; tea. lia. + eapply mkApps_eq in H1 as [? []] => //; subst. specialize (IHeval1 mfix idx (remove_last args) _ withguard eq_refl) as [args' []]. exists (args' ++ [a']). @@ -1503,23 +1503,23 @@ Proof. lia. Qed. -Lemma isEtaExp_tApp_eval {fl} {Σ} {f u v} : +Lemma isEtaExp_tApp_eval {fl} {Σ} {f u v} : with_guarded_fix -> with_constructor_as_block = false -> @eval fl Σ f v -> - isEtaExp Σ [] (tApp f u) -> + isEtaExp Σ [] (tApp f u) -> (forall kn c args block_args, v <> mkApps (tConstruct kn c block_args) args) -> (forall mfix idx args, v <> mkApps (tFix mfix idx) args) -> let (hd, args) := decompose_app (tApp f u) in match expanded_head_viewc hd with | expanded_head_construct kn c _ => False | expanded_head_fix mfix idx => - args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ + args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ [&& isEtaExp_fixapp mfix idx #|remove_last args|, forallb (fun d => isLambda d.(dbody) && isEtaExp Σ (rev_map (fun d => 1 + d.(rarg)) mfix ++ []) d.(dbody)) mfix, forallb (isEtaExp Σ []) (remove_last args) & isEtaExp Σ [] u] | expanded_head_rel n => False - | expanded_head_other _ discr => + | expanded_head_other _ discr => [&& isEtaExp Σ [] hd, forallb (isEtaExp Σ []) args, isEtaExp Σ [] f & isEtaExp Σ [] u] end. Proof. @@ -1564,7 +1564,7 @@ Qed. Lemma eval_app_cong_tApp' fl Σ t arg arg' res : - @value (switch_unguarded_fix fl) Σ t -> + @value (switch_unguarded_fix fl) Σ t -> @eval (switch_unguarded_fix fl) Σ arg arg' -> @eval (switch_unguarded_fix fl) Σ (tApp t arg') res -> @eval (switch_unguarded_fix fl) Σ (tApp t arg) res. @@ -1584,7 +1584,7 @@ Proof. - now cbn in i. Qed. -Lemma eval_value_cong {fl} {Σ} {f args args' res} : +Lemma eval_value_cong {fl} {Σ} {f args args' res} : @value (switch_unguarded_fix fl) Σ f -> All2 (@eval (switch_unguarded_fix fl) Σ) args args' -> @eval (switch_unguarded_fix fl) Σ (mkApps f args') res -> @@ -1594,7 +1594,7 @@ Proof. revert args' res; induction args using rev_ind. - intros args' res H; depelim H. now cbn. - intros args' res H. - eapply All2_app_inv_l in H as [r1 [r2 [? []]]]. depelim a0. depelim a0. subst args'. + eapply All2_app_inv_l in H as [r1 [r2 [? []]]]. depelim a0. depelim a0. subst args'. intros H. rewrite mkApps_app in H |- *. rewrite mkApps_app. eapply eval_mkApps_inv' in H as [f' [args' [evf' [evargs' evres]]]]. @@ -1605,16 +1605,16 @@ Proof. Qed. Lemma eval_app_cong_mkApps {fl} {Σ} {f f' res : EAst.term} {args args'} : - @eval (switch_unguarded_fix fl) Σ f f' → + @eval (switch_unguarded_fix fl) Σ f f' → All2 (@eval (switch_unguarded_fix fl) Σ) args args' -> - @eval (switch_unguarded_fix fl) Σ (mkApps f' args') res → + @eval (switch_unguarded_fix fl) Σ (mkApps f' args') res → @eval (switch_unguarded_fix fl) Σ (mkApps f args) res. Proof. revert args' res; induction args using rev_ind. - cbn. intros. eapply eval_trans. tea. now depelim X. - intros args' res evf evargs evf'. rewrite !mkApps_app. cbn. - eapply All2_app_inv_l in evargs as [r1 [r2 [? []]]]. depelim a0. depelim a0. subst args'. + eapply All2_app_inv_l in evargs as [r1 [r2 [? []]]]. depelim a0. depelim a0. subst args'. rewrite mkApps_app in evf'. eapply eval_mkApps_inv' in evf' as [f'' [args' [evf'' [evargs' evres]]]]. depelim evargs'. depelim evargs'. @@ -1651,8 +1651,8 @@ Lemma eval_opt_to_target {fl: WcbvFlags} {wcon : with_constructor_as_block = fal with_guarded_fix -> isEtaExp_env Σ -> wf_glob Σ -> - @eval fl Σ t v -> - isEtaExp Σ [] t -> + @eval fl Σ t v -> + isEtaExp Σ [] t -> @eval (switch_unguarded_fix fl) Σ t v. Proof. intros wguard etaΣ wfΣ. @@ -1668,7 +1668,7 @@ Proof. rewrite ha in H. eapply eval_stuck_fix_eq in H as [args' [Hargs' [[]|]]]. solve_discr. forward IHeval1 => //. - rewrite ha. eapply isEtaExp_FixApp => //. + rewrite ha. eapply isEtaExp_FixApp => //. forward IHeval2 => //. now econstructor. auto. * move: IH => /and4P [] ht0 hl ha ht. @@ -1685,7 +1685,7 @@ Proof. rewrite ha in H. eapply eval_stuck_fix_eq in H as [args' [Hargs' [[]|]]]. solve_discr. forward_keep IHeval1 => //. - rewrite ha. eapply isEtaExp_FixApp => //. + rewrite ha. eapply isEtaExp_FixApp => //. forward IHeval2 => //. forward IHeval3. eapply etaExp_csubst; tea. eapply eval_etaexp; tea. eapply eval_etaexp in IHeval1; tea. simp_eta in IHeval1. exact IHeval1. @@ -1696,17 +1696,17 @@ Proof. forward IHeval3. eapply etaExp_csubst; tea. eapply eval_etaexp; tea. eapply eval_etaexp in IHeval1; tea. simp_eta in IHeval1. exact IHeval1. econstructor; eauto. - + - intros Hexp; simp_eta in Hexp. rtoProp. econstructor. eauto. forward_keep IHeval1 => //. forward IHeval2 => //. eapply etaExp_csubst; tea. - eapply eval_etaexp in IHeval1; tea. + eapply eval_etaexp in IHeval1; tea. - simp_eta. move=> /andP[] etad etabrs. forward IHeval1 => //. unshelve epose proof (eval_etaexp etaΣ wfΣ IHeval1 etad). eauto. revert H1. - rewrite isEtaExp_Constructor => /andP[] /andP[] etac etaargs bargs. + rewrite isEtaExp_Constructor => /andP[] /andP[] etac etaargs bargs. forward_keep IHeval2 => //. eapply isEtaExp_iota_red'; eauto. eapply forallb_nth_error in etabrs; tea. erewrite e2 in etabrs. @@ -1725,7 +1725,7 @@ Proof. intros he. generalize he. move/isEtaExp_tApp'. destruct decompose_app eqn:da. - destruct expanded_head_viewc. + destruct expanded_head_viewc. * move=> [] hl [] hf [] ha /andP[]/ andP[] heta heta2 bargs. destruct block_args; inv bargs. clear H0. rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; try solve_discr. auto. @@ -1749,7 +1749,7 @@ Proof. eapply All_eval_etaexp in isel; tea. solve_all. eapply All2_impl; tea. cbn. now intros ? ? []. } destruct (eval_mkApps_inv_size IHeval3) as [f'' [args'' [evf' [evs evargs' [evres ressize]]]]]. - rewrite -[tApp _ _](mkApps_app _ _ [a]). + rewrite -[tApp _ _](mkApps_app _ _ [a]). rewrite ha. rewrite -remove_last_last //. assert (All2 (λ a a' : EAst.term, @eval (switch_unguarded_fix fl) Σ a a') @@ -1778,7 +1778,7 @@ Proof. now rewrite nth_error_nil /= in hnth. * move=> /and4P[] => ht hl hf ha. clear H0. now eapply neval_to_stuck_fix_app in H; tea. - + - clear H0. cbn -[isEtaExp] in *. intros he. generalize he. @@ -1836,14 +1836,14 @@ Proof. forward IHeval1 by tas. forward IHeval2. { eapply eval_etaexp in H; tea. - move: H; rewrite isEtaExp_mkApps // /= => /andP[] /andP[] etaapp etaargs bargs. + move: H; rewrite isEtaExp_mkApps // /= => /andP[] /andP[] etaapp etaargs bargs. eapply forallb_nth_error in etaargs; tea. now erewrite e3 in etaargs. } eapply eval_proj; tea. - congruence. - simp_eta => etad. forward IHeval by tas. - eapply eval_proj_prop ; tea. + eapply eval_proj_prop ; tea. - move/isEtaExp_tApp'. destruct decompose_app eqn:da. rewrite (decompose_app_inv da). @@ -1856,7 +1856,7 @@ Proof. intros hevd. rewrite (remove_last_last l0 a hl). rewrite -[tApp _ _](mkApps_app _ _ [a']). - eapply eval_mkApps_Construct; tea. + eapply eval_mkApps_Construct; tea. { constructor. cbn [atom]; rewrite e e0 //. } { len. rewrite (All2_length hargs). lia. } eapply All2_app. diff --git a/erasure/theories/EExtends.v b/erasure/theories/EExtends.v index d05c076ab..04c0f196c 100644 --- a/erasure/theories/EExtends.v +++ b/erasure/theories/EExtends.v @@ -43,7 +43,7 @@ Section EEnvFlags. intros Σ cst mdecl idecl cdecl [Hidecl Hcdecl] Σ' X2 H2. split; eauto. eapply weakening_env_declared_inductive; eauto. Qed. - + Lemma extends_wf_glob {Σ Σ'} : extends Σ Σ' -> wf_glob Σ' -> wf_glob Σ. Proof using Type. intros [? ->]. @@ -51,10 +51,10 @@ Section EEnvFlags. intros wf; depelim wf. eauto. Qed. - Definition global_subset (Σ Σ' : global_declarations) := + Definition global_subset (Σ Σ' : global_declarations) := forall kn d, lookup_env Σ kn = Some d -> lookup_env Σ' kn = Some d. - Lemma lookup_env_In d Σ : + Lemma lookup_env_In d Σ : wf_glob Σ -> lookup_env Σ d.1 = Some d.2 <-> In d Σ. Proof using Type. @@ -73,7 +73,7 @@ Section EEnvFlags. exact IHwf. Qed. - Lemma global_subset_In Σ Σ' : + Lemma global_subset_In Σ Σ' : wf_glob Σ -> wf_glob Σ' -> global_subset Σ Σ' <-> forall d, In d Σ -> In d Σ'. Proof using Type. @@ -87,7 +87,7 @@ Section EEnvFlags. eapply (lookup_env_In (kn, d)) => //. eauto. Qed. - Lemma global_subset_cons d Σ Σ' : + Lemma global_subset_cons d Σ Σ' : global_subset Σ Σ' -> global_subset (d :: Σ) (d :: Σ'). Proof using Type. @@ -96,7 +96,7 @@ Section EEnvFlags. eapply sub. Qed. - Lemma fresh_global_subset Σ Σ' kn : + Lemma fresh_global_subset Σ Σ' kn : wf_glob Σ -> wf_glob Σ' -> global_subset Σ Σ' -> fresh_global kn Σ' -> fresh_global kn Σ. @@ -111,7 +111,7 @@ Section EEnvFlags. destruct fr. cbn in H. congruence. Qed. - Lemma global_subset_cons_right d Σ Σ' : + Lemma global_subset_cons_right d Σ Σ' : wf_glob Σ -> wf_glob (d :: Σ') -> global_subset Σ Σ' -> global_subset Σ (d :: Σ'). diff --git a/erasure/theories/EGenericMapEnv.v b/erasure/theories/EGenericMapEnv.v index 1f1df5bc2..a664c58d8 100644 --- a/erasure/theories/EGenericMapEnv.v +++ b/erasure/theories/EGenericMapEnv.v @@ -1,8 +1,8 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import Utf8 Program. -From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap. +From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap. From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EArities - ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap + ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap EWcbvEval EEtaExpanded ECSubst EWcbvEvalEtaInd EProgram. Local Open Scope string_scope. @@ -18,7 +18,7 @@ Section sec. Variable gen_transform : global_context -> term -> term. -Definition gen_transform_constant_decl Σ cb := +Definition gen_transform_constant_decl Σ cb := {| cst_body := option_map (gen_transform Σ) cb.(cst_body) |}. Definition gen_transform_decl Σ d := @@ -27,7 +27,7 @@ Definition gen_transform_decl Σ d := | InductiveDecl idecl => d end. -Definition gen_transform_env Σ := +Definition gen_transform_env Σ := map (on_snd (gen_transform_decl Σ)) Σ. Program Fixpoint gen_transform_env' Σ : global_context := @@ -39,7 +39,7 @@ end. Import EGlobalEnv EExtends. Lemma extends_lookup_projection {efl : EEnvFlags} {Σ Σ' p} : extends Σ Σ' -> wf_glob Σ' -> -isSome (lookup_projection Σ p) -> +isSome (lookup_projection Σ p) -> lookup_projection Σ p = lookup_projection Σ' p. Proof. intros ext wf; cbn -[lookup_projection]. @@ -57,7 +57,7 @@ forall n, EWellformed.wellformed Σ n t -> forall {Σ' : global_context}, extends Σ Σ' -> wf_glob Σ' -> gen_transform Σ t = gen_transform Σ' t. -Lemma wellformed_gen_transform_decl_extends {Σ : global_context} t : +Lemma wellformed_gen_transform_decl_extends {Σ : global_context} t : wf_global_decl Σ t -> forall {Σ' : global_context}, extends Σ Σ' -> wf_glob Σ' -> gen_transform_decl Σ t = gen_transform_decl Σ' t. @@ -68,10 +68,10 @@ destruct (cst_body c) => /= //. f_equal. now eapply wellformed_gen_transform_extends. Qed. -Lemma lookup_env_gen_transform_env_Some {Σ : global_context} kn d : +Lemma lookup_env_gen_transform_env_Some {Σ : global_context} kn d : wf_glob Σ -> lookup_env Σ kn = Some d -> -∑ Σ' : global_context, +∑ Σ' : global_context, [× extends Σ' Σ, wf_global_decl Σ' d & lookup_env (gen_transform_env Σ) kn = Some (gen_transform_decl Σ' d)]. Proof. @@ -83,7 +83,7 @@ case: eqb_specT => //. cbn. now depelim wfg. f_equal. symmetry. eapply wellformed_gen_transform_decl_extends. cbn. now depelim wfg. cbn. now exists [a]. now cbn. -- intros _. +- intros _. cbn in IHΣ. forward IHΣ. now depelim wfg. intros hl. specialize (IHΣ hl) as [Σ'' [ext wfgd hl']]. exists Σ''. split => //. @@ -104,14 +104,14 @@ induction Σ; cbn; auto. case: eqb_spec => //. Qed. -Lemma lookup_env_gen_transform_env_None {Σ : global_context} kn : +Lemma lookup_env_gen_transform_env_None {Σ : global_context} kn : lookup_env Σ kn = None -> lookup_env (gen_transform_env Σ) kn = None. Proof. cbn. intros hl. rewrite lookup_env_map_snd hl //. Qed. -Lemma lookup_env_gen_transform {Σ : global_context} kn : +Lemma lookup_env_gen_transform {Σ : global_context} kn : wf_glob Σ -> lookup_env (gen_transform_env Σ) kn = option_map (gen_transform_decl Σ) (lookup_env Σ kn). Proof. @@ -120,12 +120,12 @@ destruct (lookup_env Σ kn) eqn:hl. - eapply lookup_env_gen_transform_env_Some in hl as [Σ' [ext wf' hl']] => /=. rewrite hl'. f_equal. eapply wellformed_gen_transform_decl_extends; eauto. auto. - + - cbn. now eapply lookup_env_gen_transform_env_None in hl. Qed. -Lemma is_propositional_gen_transform {Σ : global_context} ind : +Lemma is_propositional_gen_transform {Σ : global_context} ind : wf_glob Σ -> inductive_isprop_and_pars Σ ind = inductive_isprop_and_pars (gen_transform_env Σ) ind. Proof. @@ -133,11 +133,11 @@ Proof. rewrite /lookup_inductive /lookup_minductive. rewrite (lookup_env_gen_transform (inductive_mind ind) wf). rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive - /GlobalContextMap.lookup_minductive. + /GlobalContextMap.lookup_minductive. destruct lookup_env as [[decl|]|] => //. Qed. -Lemma is_propositional_cstr_gen_transform {Σ : global_context} ind c : +Lemma is_propositional_cstr_gen_transform {Σ : global_context} ind c : wf_glob Σ -> constructor_isprop_pars_decl Σ ind c = constructor_isprop_pars_decl (gen_transform_env Σ) ind c. Proof. @@ -145,7 +145,7 @@ Proof. rewrite /lookup_constructor /lookup_inductive /lookup_minductive. rewrite (lookup_env_gen_transform (inductive_mind ind) wf). rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive - /GlobalContextMap.lookup_minductive. + /GlobalContextMap.lookup_minductive. destruct lookup_env as [[decl|]|] => //. Qed. @@ -174,7 +174,7 @@ Proof. Qed. Lemma constructor_isprop_pars_decl_inductive {Σ ind c} {prop pars cdecl} : - constructor_isprop_pars_decl Σ ind c = Some (prop, pars, cdecl) -> + constructor_isprop_pars_decl Σ ind c = Some (prop, pars, cdecl) -> inductive_isprop_and_pars Σ ind = Some (prop, pars). Proof. rewrite /constructor_isprop_pars_decl /inductive_isprop_and_pars /lookup_constructor. @@ -194,9 +194,9 @@ Proof. rewrite wellformed_mkApps //. eapply andP. Qed. -Lemma gen_transform_env_extends' {Σ Σ' : global_context} : +Lemma gen_transform_env_extends' {Σ Σ' : global_context} : extends Σ Σ' -> - wf_glob Σ' -> + wf_glob Σ' -> List.map (on_snd (gen_transform_decl Σ)) Σ = List.map (on_snd (gen_transform_decl Σ')) Σ. Proof. @@ -236,14 +236,14 @@ Variable Pre : global_context -> term -> Prop. Hypothesis gen_transform_wellformed : forall {Σ : global_context} n t, has_tBox -> has_tRel -> Pre Σ t -> - @wf_glob efl Σ -> @EWellformed.wellformed efl Σ n t -> + @wf_glob efl Σ -> @EWellformed.wellformed efl Σ n t -> EWellformed.wellformed (efl := efl') Σ n (gen_transform Σ t). Import EWellformed. Lemma gen_transform_wellformed_irrel {Σ : global_context} t : wf_glob Σ -> - forall n, wellformed (efl := efl') Σ n t -> + forall n, wellformed (efl := efl') Σ n t -> wellformed (efl := efl') (gen_transform_env Σ) n t. Proof. intros wfΣ. induction t using EInduction.term_forall_list_ind; cbn => //. @@ -267,7 +267,7 @@ Qed. Lemma gen_transform_wellformed_decl_irrel {Σ : global_context} d : wf_glob Σ -> - wf_global_decl (efl:= efl') Σ d -> + wf_global_decl (efl:= efl') Σ d -> wf_global_decl (efl := efl') (gen_transform_env Σ) d. Proof. intros wf; destruct d => /= //. @@ -281,7 +281,7 @@ Hypothesis cstrs_efl : forall _ : is_true (@has_cstr_params efl), is_true (@has_ Definition Pre_decl Σ d := match d with ConstantDecl cb => match cb.(cst_body) with Some b => Pre Σ b | _ => True end | _ => True end. Lemma gen_transform_decl_wf {Σ : global_context} : - has_tBox -> has_tRel -> wf_glob Σ -> + has_tBox -> has_tRel -> wf_glob Σ -> forall d, wf_global_decl Σ d -> Pre_decl Σ d -> wf_global_decl (efl := efl') (gen_transform_env Σ) (gen_transform_decl Σ d). Proof. @@ -298,7 +298,7 @@ Proof. left. eapply cstrs_efl. now rewrite H. Qed. -Lemma fresh_global_gen_transform_env {Σ : global_context} kn : +Lemma fresh_global_gen_transform_env {Σ : global_context} kn : fresh_global kn Σ -> fresh_global kn (gen_transform_env Σ). Proof. diff --git a/erasure/theories/EGlobalEnv.v b/erasure/theories/EGlobalEnv.v index 7294462e2..d4bad798c 100644 --- a/erasure/theories/EGlobalEnv.v +++ b/erasure/theories/EGlobalEnv.v @@ -5,7 +5,7 @@ From MetaCoq.Erasure Require Import EAst EAstUtils ELiftSubst EReflect ECSubst. Require Import ssreflect. Import MCMonadNotation. -(** * Global environments +(** * Global environments Inductive relations for reduction, conversion and typing of CIC terms. @@ -39,26 +39,26 @@ Definition declared_projection Σ (proj : projection) mdecl idecl cdecl pdecl : List.nth_error idecl.(ind_projs) proj.(proj_arg) = Some pdecl /\ proj.(proj_npars) = ind_npars mdecl. -Lemma elookup_env_cons_fresh {kn d Σ kn'} : +Lemma elookup_env_cons_fresh {kn d Σ kn'} : kn <> kn' -> EGlobalEnv.lookup_env ((kn, d) :: Σ) kn' = EGlobalEnv.lookup_env Σ kn'. Proof. simpl. change (eq_kername kn' kn) with (eqb kn' kn). - destruct (eqb_spec kn' kn). subst => //. auto. + destruct (eqb_spec kn' kn). subst => //. auto. Qed. Section Lookups. Context (Σ : global_declarations). Definition lookup_constant kn : option constant_body := - decl <- lookup_env Σ kn;; + decl <- lookup_env Σ kn;; match decl with | ConstantDecl cdecl => ret cdecl | InductiveDecl mdecl => None end. Definition lookup_minductive kn : option mutual_inductive_body := - decl <- lookup_env Σ kn;; + decl <- lookup_env Σ kn;; match decl with | ConstantDecl _ => None | InductiveDecl mdecl => ret mdecl @@ -68,30 +68,30 @@ Section Lookups. mdecl <- lookup_minductive (inductive_mind kn) ;; idecl <- nth_error mdecl.(ind_bodies) (inductive_ind kn) ;; ret (mdecl, idecl). - - Definition lookup_inductive_pars kn : option nat := + + Definition lookup_inductive_pars kn : option nat := mdecl <- lookup_minductive kn ;; ret mdecl.(ind_npars). - - Definition lookup_inductive_kind kn : option recursivity_kind := + + Definition lookup_inductive_kind kn : option recursivity_kind := mdecl <- lookup_minductive kn ;; ret mdecl.(ind_finite). - + Definition lookup_constructor kn c : option (mutual_inductive_body * one_inductive_body * constructor_body) := '(mdecl, idecl) <- lookup_inductive kn ;; cdecl <- nth_error idecl.(ind_ctors) c ;; ret (mdecl, idecl, cdecl). - - Definition lookup_constructor_pars_args kn c : option (nat * nat) := + + Definition lookup_constructor_pars_args kn c : option (nat * nat) := '(mdecl, idecl, cdecl) <- lookup_constructor kn c ;; ret (mdecl.(ind_npars), cdecl.(cstr_nargs)). - Definition lookup_projection (p : projection) : + Definition lookup_projection (p : projection) : option (mutual_inductive_body * one_inductive_body * constructor_body * projection_body) := '(mdecl, idecl, cdecl) <- lookup_constructor p.(proj_ind) 0 ;; pdecl <- nth_error idecl.(ind_projs) p.(proj_arg) ;; ret (mdecl, idecl, cdecl, pdecl). - + End Lookups. Lemma declared_constant_lookup {Σ kn cdecl} : @@ -104,7 +104,7 @@ Qed. Lemma declared_minductive_lookup {Σ ind mdecl} : declared_minductive Σ ind mdecl -> lookup_minductive Σ ind = Some mdecl. -Proof. +Proof. rewrite /declared_minductive /lookup_minductive. intros -> => /= //. Qed. @@ -118,7 +118,7 @@ Proof. Qed. Lemma declared_constructor_lookup {Σ id mdecl idecl cdecl} : - declared_constructor Σ id mdecl idecl cdecl -> + declared_constructor Σ id mdecl idecl cdecl -> lookup_constructor Σ id.1 id.2 = Some (mdecl, idecl, cdecl). Proof. intros []. unfold lookup_constructor. @@ -126,7 +126,7 @@ Proof. Qed. Lemma declared_projection_lookup {Σ p mdecl idecl cdecl pdecl} : - declared_projection Σ p mdecl idecl cdecl pdecl -> + declared_projection Σ p mdecl idecl cdecl pdecl -> lookup_projection Σ p = Some (mdecl, idecl, cdecl, pdecl). Proof. intros [hc [hp hn]]. unfold lookup_projection. @@ -153,7 +153,7 @@ Qed. (** Knowledge of propositionality status of an inductive type and parameters *) -Lemma lookup_constructor_pars_args_cstr_arity Σ ind c mdecl idecl cdecl : +Lemma lookup_constructor_pars_args_cstr_arity Σ ind c mdecl idecl cdecl : lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> lookup_constructor_pars_args Σ ind c = Some (mdecl.(ind_npars), cdecl.(cstr_nargs)). Proof. @@ -169,17 +169,17 @@ Definition constructor_isprop_pars_decl Σ ind c := '(mdecl, idecl, cdecl) <- lookup_constructor Σ ind c ;; ret (idecl.(ind_propositional), mdecl.(ind_npars), cdecl). Arguments constructor_isprop_pars_decl : simpl never. - -Definition closed_decl (d : EAst.global_decl) := + +Definition closed_decl (d : EAst.global_decl) := match d with - | EAst.ConstantDecl cb => + | EAst.ConstantDecl cb => option_default (ELiftSubst.closedn 0) (EAst.cst_body cb) true | EAst.InductiveDecl _ => true end. -Definition closed_env (Σ : EAst.global_declarations) := +Definition closed_env (Σ : EAst.global_declarations) := forallb (test_snd closed_decl) Σ. - + (** Environment extension and uniqueness of declarations in well-formed global environments *) Definition extends (Σ Σ' : global_declarations) := ∑ Σ'', Σ' = (Σ'' ++ Σ)%list. diff --git a/erasure/theories/EInduction.v b/erasure/theories/EInduction.v index 3b28ad983..789231ae0 100644 --- a/erasure/theories/EInduction.v +++ b/erasure/theories/EInduction.v @@ -25,7 +25,7 @@ Lemma term_forall_list_ind : P t -> forall t0 : term, P t0 -> P (tLetIn n t t0)) -> (forall t u : term, P t -> P u -> P (tApp t u)) -> (forall s, P (tConst s)) -> - (forall (i : inductive) (n : nat) (args : list term), + (forall (i : inductive) (n : nat) (args : list term), All P args -> P (tConstruct i n args)) -> (forall (p : inductive * nat) (t : term), P t -> forall l : list (list name * term), @@ -38,7 +38,7 @@ Lemma term_forall_list_ind : Proof. intros until t. revert t. fix auxt 1. - move auxt at top. + move auxt at top. destruct t; match goal with H : _ |- _ => apply H end; auto. @@ -120,7 +120,7 @@ Qed. Lemma decompose_app_size t : let da := decompose_app t in size da.1 + list_size size da.2 = size t. -Proof. +Proof. unfold decompose_app. rewrite (decompose_app_rec_size t []); cbn. lia. Qed. @@ -183,8 +183,8 @@ Qed. Section All_rec. Context (P : term -> Type). Context {A} (proj : A -> term). - - Equations? All_rec (l : list A) (auxt : forall y, size y < (list_size (fun x => size (proj x)) l) -> P y) : + + Equations? All_rec (l : list A) (auxt : forall y, size y < (list_size (fun x => size (proj x)) l) -> P y) : All (fun x => P (proj x)) l := All_rec [] auxt := All_nil; All_rec (x :: xs) auxt := All_cons (auxt (proj x) _) (All_rec xs (fun y H => auxt y _)). @@ -229,11 +229,11 @@ Section MkApps_rec. | tBox => pbox | tLambda n1 t => plam n1 t (rec t) | tLetIn n2 t0 t1 => plet n2 t0 (rec t0) t1 (rec t1) - | tApp t2 t3 with inspect (decompose_app (tApp t2 t3)) := - { | exist _ (t, l) da := + | tApp t2 t3 with inspect (decompose_app (tApp t2 t3)) := + { | exist _ (t, l) da := let napp := decompose_app_notApp _ _ _ da in let nonnil := decompose_app_app _ _ _ _ da in - let pt := rec t in + let pt := rec t in let pl := All_rec P id l (fun x H => rec x) in rew _ in papp t l napp nonnil pt pl } | tConst k => pconst k @@ -251,7 +251,7 @@ Section MkApps_rec. abstract (destruct l; try congruence; cbn; lia). - clear -da rec H. pose proof (decompose_app_size (tApp t2 t3)). - rewrite da in H0. cbn in H0. rewrite <- H0. + rewrite da in H0. cbn in H0. rewrite <- H0. unfold id in H. change (fun x => size x) with size in H. abstract lia. - clear -da. abstract (eapply decompose_app_inv in da; now symmetry). Qed. @@ -277,7 +277,7 @@ Section MkApps_rec. (pprim : forall p, P (tPrim p)). Import EqNotations. - + Equations case (t : term) : P t := | tRel n => prel n | tVar n => pvar n @@ -285,8 +285,8 @@ Section MkApps_rec. | tBox => pbox | tLambda n1 t => plam n1 t | tLetIn n2 t0 t1 => plet n2 t0 t1 - | tApp t2 t3 with inspect (decompose_app (tApp t2 t3)) := - { | exist _ (t, l) da := + | tApp t2 t3 with inspect (decompose_app (tApp t2 t3)) := + { | exist _ (t, l) da := let napp := decompose_app_notApp _ _ _ da in let nonnil := decompose_app_app _ _ _ _ da in rew [P] (eq_sym (decompose_app_inv da)) in papp t l napp nonnil } @@ -302,9 +302,9 @@ Section MkApps_rec. End MkAppsInd. -(*Equations? head (t : term) : term +(*Equations? head (t : term) : term by wf t (fun x y : term => size x < size y) := - | t with TermSpineView.view t := + | t with TermSpineView.view t := { | TermSpineView.tApp f l Hf Hl => head f; | x => _ }. Proof. @@ -337,8 +337,8 @@ Proof. Definition view : term -> t := MkAppsInd.rec (P:=fun _ => t) - tBox tRel tVar - (fun n l _ => tEvar n l) + tBox tRel tVar + (fun n l _ => tEvar n l) (fun n t _ => tLambda n t) (fun n b _ t _ => tLetIn n b t) (fun f l napp nnil _ _ => tApp f l napp nnil) diff --git a/erasure/theories/EInlineProjections.v b/erasure/theories/EInlineProjections.v index 795ff789a..02a6f07be 100644 --- a/erasure/theories/EInlineProjections.v +++ b/erasure/theories/EInlineProjections.v @@ -25,27 +25,27 @@ Hint Constructors eval : core. (** Allow everything in terms *) Definition switch_no_params (efl : EEnvFlags) := - {| has_axioms := has_axioms; + {| has_axioms := has_axioms; has_cstr_params := false; term_switches := term_switches ; cstr_as_blocks := false |}. Definition flags_after_projs := (switch_no_params all_env_flags). -Local Existing Instance flags_after_projs. +Local Existing Instance flags_after_projs. Arguments lookup_projection : simpl never. Arguments GlobalContextMap.lookup_projection : simpl never. -Lemma lookup_inductive_wellformed {efl : EEnvFlags} Σ (kn : kername) +Lemma lookup_inductive_wellformed {efl : EEnvFlags} Σ (kn : kername) (decl : mutual_inductive_body) : wf_glob Σ → lookup_minductive Σ kn = Some decl → wf_minductive decl. Proof. intros wfΣ. - rewrite /lookup_minductive. + rewrite /lookup_minductive. destruct lookup_env as [[]|] eqn:hl => //=. intros [= <-]. now eapply lookup_env_wellformed in hl. Qed. -Lemma wellformed_projection_args {efl : EEnvFlags} {Σ p mdecl idecl cdecl pdecl} : +Lemma wellformed_projection_args {efl : EEnvFlags} {Σ p mdecl idecl cdecl pdecl} : wf_glob Σ -> lookup_projection Σ p = Some (mdecl, idecl, cdecl, pdecl) -> p.(proj_arg) < cdecl.(cstr_nargs). @@ -83,8 +83,8 @@ Section optimize. | tLetIn na b b' => tLetIn na (optimize b) (optimize b') | tCase ind c brs => tCase ind (optimize c) (map (on_snd optimize) brs) | tProj p c => - match GlobalContextMap.lookup_projection Σ p with - | Some (mdecl, idecl, cdecl, pdecl) => + match GlobalContextMap.lookup_projection Σ p with + | Some (mdecl, idecl, cdecl, pdecl) => tCase (p.(proj_ind), p.(proj_npars)) (optimize c) [(unfold cdecl.(cstr_nargs) (fun n => nAnon), tRel (cdecl.(cstr_nargs) - S p.(proj_arg)))] | _ => tProj p (optimize c) end @@ -116,8 +116,8 @@ Section optimize. Proof. destruct t => //. Qed. Lemma isBox_optimize t : isBox t -> isBox (optimize t). Proof. destruct t => //. Qed. - - Lemma wf_optimize t k : + + Lemma wf_optimize t k : wf_glob Σ -> wellformed Σ k t -> wellformed Σ k (optimize t). Proof using Type. @@ -142,15 +142,15 @@ Section optimize. now eapply isLambda_optimize. solve_all. - len. rtoProp; solve_all. rewrite forallb_map; solve_all. Qed. - - Lemma optimize_csubst {a k b} n : + + Lemma optimize_csubst {a k b} n : wf_glob Σ -> wellformed Σ (k + n) b -> optimize (ECSubst.csubst a k b) = ECSubst.csubst (optimize a) k (optimize b). Proof using Type. intros wfΣ. induction b in k |- * using EInduction.term_forall_list_ind; simpl; auto; - intros wft; try easy; + intros wft; try easy; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; unfold wf_fix, test_def in *; simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. @@ -174,7 +174,7 @@ Section optimize. eapply a0. now rewrite -Nat.add_assoc. Qed. - Lemma optimize_substl s t : + Lemma optimize_substl s t : wf_glob Σ -> forallb (wellformed Σ 0) s -> wellformed Σ #|s| t -> @@ -199,7 +199,7 @@ Section optimize. now rewrite List.rev_length. now rewrite map_rev map_skipn. Qed. - + Lemma optimize_fix_subst mfix : EGlobalEnv.fix_subst (map (map_def optimize) mfix) = map optimize (EGlobalEnv.fix_subst mfix). Proof using Type. unfold EGlobalEnv.fix_subst. @@ -218,7 +218,7 @@ Section optimize. f_equal; auto. Qed. - Lemma optimize_cunfold_fix mfix idx n f : + Lemma optimize_cunfold_fix mfix idx n f : wf_glob Σ -> wellformed Σ 0 (tFix mfix idx) -> cunfold_fix mfix idx = Some (n, f) -> @@ -227,7 +227,7 @@ Section optimize. intros wfΣ hfix. unfold cunfold_fix. rewrite nth_error_map. - cbn in hfix. move/andP: hfix => [] hlam /andP[] hidx hfix. + cbn in hfix. move/andP: hfix => [] hlam /andP[] hidx hfix. destruct nth_error eqn:hnth => //. intros [= <- <-] => /=. f_equal. rewrite optimize_substl //. eapply wellformed_fix_subst => //. @@ -236,7 +236,7 @@ Section optimize. now rewrite optimize_fix_subst. Qed. - Lemma optimize_cunfold_cofix mfix idx n f : + Lemma optimize_cunfold_cofix mfix idx n f : wf_glob Σ -> wellformed Σ 0 (tCoFix mfix idx) -> cunfold_cofix mfix idx = Some (n, f) -> @@ -245,7 +245,7 @@ Section optimize. intros wfΣ hfix. unfold cunfold_cofix. rewrite nth_error_map. - cbn in hfix. move/andP: hfix => [] hidx hfix. + cbn in hfix. move/andP: hfix => [] hidx hfix. destruct nth_error eqn:hnth => //. intros [= <- <-] => /=. f_equal. rewrite optimize_substl //. eapply wellformed_cofix_subst => //. @@ -256,32 +256,32 @@ Section optimize. End optimize. -Definition optimize_constant_decl Σ cb := +Definition optimize_constant_decl Σ cb := {| cst_body := option_map (optimize Σ) cb.(cst_body) |}. - + Definition optimize_decl Σ d := match d with | ConstantDecl cb => ConstantDecl (optimize_constant_decl Σ cb) | InductiveDecl idecl => d end. -Definition optimize_env Σ := +Definition optimize_env Σ := map (on_snd (optimize_decl Σ)) Σ.(GlobalContextMap.global_decls). - + Import EnvMap. Program Fixpoint optimize_env' Σ : EnvMap.fresh_globals Σ -> global_context := match Σ with | [] => fun _ => [] | hd :: tl => fun HΣ => - let Σg := GlobalContextMap.make tl (fresh_globals_cons_inv HΣ) in - on_snd (optimize_decl Σg) hd :: optimize_env' tl (fresh_globals_cons_inv HΣ) + let Σg := GlobalContextMap.make tl (fresh_globals_cons_inv HΣ) in + on_snd (optimize_decl Σg) hd :: optimize_env' tl (fresh_globals_cons_inv HΣ) end. Import EGlobalEnv EExtends. Lemma extends_lookup_projection {efl : EEnvFlags} {Σ Σ' p} : extends Σ Σ' -> wf_glob Σ' -> - isSome (lookup_projection Σ p) -> + isSome (lookup_projection Σ p) -> lookup_projection Σ p = lookup_projection Σ' p. Proof. intros ext wf; cbn. @@ -291,7 +291,7 @@ Proof. rewrite (extends_lookup_constructor wf ext _ _ _ hl) //. Qed. -Lemma wellformed_optimize_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : +Lemma wellformed_optimize_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : forall n, EWellformed.wellformed Σ n t -> forall {Σ' : GlobalContextMap.t}, extends Σ Σ' -> wf_glob Σ' -> optimize Σ t = optimize Σ' t. @@ -307,7 +307,7 @@ Proof. now cbn in H3. Qed. -Lemma wellformed_optimize_decl_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : +Lemma wellformed_optimize_decl_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : wf_global_decl Σ t -> forall {Σ' : GlobalContextMap.t}, extends Σ Σ' -> wf_glob Σ' -> optimize_decl Σ t = optimize_decl Σ' t. @@ -318,10 +318,10 @@ Proof. now eapply wellformed_optimize_extends. Qed. -Lemma lookup_env_optimize_env_Some {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn d : +Lemma lookup_env_optimize_env_Some {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn d : wf_glob Σ -> GlobalContextMap.lookup_env Σ kn = Some d -> - ∑ Σ' : GlobalContextMap.t, + ∑ Σ' : GlobalContextMap.t, [× extends Σ' Σ, wf_global_decl Σ' d & lookup_env (optimize_env Σ) kn = Some (optimize_decl Σ' d)]. Proof. @@ -336,7 +336,7 @@ Proof. cbn. now depelim wfg. f_equal. symmetry. eapply wellformed_optimize_decl_extends. cbn. now depelim wfg. cbn. now exists [a]. now cbn. - - intros _. + - intros _. set (Σ' := GlobalContextMap.make Σ (fresh_globals_cons_inv wf)). specialize (IHΣ (GlobalContextMap.map Σ') (GlobalContextMap.repr Σ') (GlobalContextMap.wf Σ')). cbn in IHΣ. forward IHΣ. now depelim wfg. @@ -359,7 +359,7 @@ Proof. case: eqb_spec => //. Qed. -Lemma lookup_env_optimize_env_None {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : +Lemma lookup_env_optimize_env_None {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : GlobalContextMap.lookup_env Σ kn = None -> lookup_env (optimize_env Σ) kn = None. Proof. @@ -368,7 +368,7 @@ Proof. cbn. intros hl. rewrite lookup_env_map_snd hl //. Qed. -Lemma lookup_env_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : +Lemma lookup_env_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : wf_glob Σ -> lookup_env (optimize_env Σ) kn = option_map (optimize_decl Σ) (lookup_env Σ kn). Proof. @@ -378,11 +378,11 @@ Proof. - eapply lookup_env_optimize_env_Some in hl as [Σ' [ext wf' hl']] => /=. rewrite hl'. f_equal. eapply wellformed_optimize_decl_extends; eauto. auto. - + - cbn. now eapply lookup_env_optimize_env_None in hl. Qed. -Lemma is_propositional_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind : +Lemma is_propositional_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind : wf_glob Σ -> inductive_isprop_and_pars Σ ind = inductive_isprop_and_pars (optimize_env Σ) ind. Proof. @@ -390,11 +390,11 @@ Proof. rewrite /lookup_inductive /lookup_minductive. rewrite (lookup_env_optimize (inductive_mind ind) wf). rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive - /GlobalContextMap.lookup_minductive. + /GlobalContextMap.lookup_minductive. destruct lookup_env as [[decl|]|] => //. Qed. -Lemma is_propositional_cstr_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind c : +Lemma is_propositional_cstr_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind c : wf_glob Σ -> constructor_isprop_pars_decl Σ ind c = constructor_isprop_pars_decl (optimize_env Σ) ind c. Proof. @@ -402,7 +402,7 @@ Proof. rewrite /lookup_constructor /lookup_inductive /lookup_minductive. rewrite (lookup_env_optimize (inductive_mind ind) wf). rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive - /GlobalContextMap.lookup_minductive. + /GlobalContextMap.lookup_minductive. destruct lookup_env as [[decl|]|] => //. Qed. @@ -448,7 +448,7 @@ Proof. Qed. Lemma constructor_isprop_pars_decl_inductive {Σ ind c} {prop pars cdecl} : - constructor_isprop_pars_decl Σ ind c = Some (prop, pars, cdecl) -> + constructor_isprop_pars_decl Σ ind c = Some (prop, pars, cdecl) -> inductive_isprop_and_pars Σ ind = Some (prop, pars). Proof. rewrite /constructor_isprop_pars_decl /inductive_isprop_and_pars /lookup_constructor. @@ -474,7 +474,7 @@ Proof. intros clt. rewrite csubst_closed //. now apply IHs. Qed. -Lemma substl_rel s k a : +Lemma substl_rel s k a : closed a -> nth_error s k = Some a -> substl s (tRel k) = a. @@ -484,7 +484,7 @@ Proof. - rewrite nth_error_nil //. - destruct k => //=. * intros [= ->]. rewrite substl_closed //. - * intros hnth. now apply IHs. + * intros hnth. now apply IHs. Qed. @@ -502,7 +502,7 @@ Proof. eapply eval_wellformed in ev2; tea => //. eapply eval_wellformed in ev1; tea => //. econstructor; eauto. - rewrite -(optimize_csubst _ 1) //. + rewrite -(optimize_csubst _ 1) //. apply IHev3. eapply wellformed_csubst => //. - move/andP => [] clb0 clb1. @@ -555,8 +555,8 @@ Proof. rewrite optimize_mkApps in IHev1 |- *. simpl in *. eapply eval_fix_value. auto. auto. auto. eapply optimize_cunfold_fix; eauto. - now rewrite map_length. - + now rewrite map_length. + - move/andP => [] clf cla. eapply eval_wellformed in ev1 => //. eapply eval_wellformed in ev2; tas => //. @@ -589,7 +589,7 @@ Proof. eapply eval_cofix_case. eauto. eapply optimize_cunfold_cofix; tea. rewrite optimize_mkApps in IHev2 => //. - + - rewrite /declared_constant in isdecl. move: (lookup_env_optimize c wfΣ). rewrite isdecl /= //. @@ -598,7 +598,7 @@ Proof. apply IHev. eapply lookup_env_wellformed in wfΣ; tea. move: wfΣ. rewrite /wf_global_decl /= e //. - + - move=> /andP[] iss cld. rewrite GlobalContextMap.lookup_projection_spec. eapply eval_wellformed in ev1; tea => //. @@ -619,7 +619,7 @@ Proof. eapply wf_optimize in wfargs => //. now eapply wellformed_closed in wfargs. } pose proof (wellformed_projection_args wfΣ hl'). cbn in H1. - rewrite nth_error_rev. len. rewrite skipn_length. lia. + rewrite nth_error_rev. len. rewrite skipn_length. lia. rewrite List.rev_involutive. len. rewrite skipn_length. rewrite nth_error_skipn nth_error_map. rewrite e2 -H1. @@ -634,7 +634,7 @@ Proof. rewrite GlobalContextMap.lookup_projection_spec. destruct lookup_projection as [[[[mdecl idecl] cdecl'] pdecl]|] eqn:hl' => //. pose proof (lookup_projection_lookup_constructor hl'). - simpl in H. + simpl in H. move: e0. rewrite /inductive_isprop_and_pars. rewrite (lookup_constructor_lookup_inductive H) /=. intros [= eq <-]. @@ -663,20 +663,20 @@ Proof. destruct ev1; simpl in *; eauto. * destruct t => //; rewrite optimize_mkApps /=. * destruct with_guarded_fix. - + move: i. + + move: i. rewrite !negb_or. rewrite optimize_mkApps !isFixApp_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //. rewrite !andb_true_r. rtoProp; intuition auto. - destruct v => /= //. destruct v => /= //. destruct v => /= //. - + move: i. + destruct v => /= //. + + move: i. rewrite !negb_or. rewrite optimize_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //. - destruct v => /= //. + destruct v => /= //. - destruct t => //. all:constructor; eauto. cbn [atom optimize] in i |- *. @@ -711,7 +711,7 @@ Proof. eapply expanded_tConstruct_app. destruct H as [[H ?] ?]. split => //. split => //. red. - red in H. rewrite lookup_env_optimize // /= H //. 1-2:eauto. auto. solve_all. + red in H. rewrite lookup_env_optimize // /= H //. 1-2:eauto. auto. solve_all. Qed. Lemma optimize_expanded_decl {Σ : GlobalContextMap.t} t : expanded_decl Σ t -> expanded_decl Σ (optimize_decl Σ t). @@ -728,9 +728,9 @@ Proof. apply optimize_expanded_irrel. Qed. -Lemma optimize_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : +Lemma optimize_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : extends Σ Σ' -> - wf_glob Σ' -> + wf_glob Σ' -> List.map (on_snd (optimize_decl Σ)) Σ.(GlobalContextMap.global_decls) = List.map (on_snd (optimize_decl Σ')) Σ.(GlobalContextMap.global_decls). Proof. @@ -779,14 +779,14 @@ Proof. clear map repr. induction 1; cbn; constructor; auto. cbn in IHexpanded_global_declarations. - unshelve eapply IHexpanded_global_declarations. now depelim wfg. cbn. + unshelve eapply IHexpanded_global_declarations. now depelim wfg. cbn. set (Σ' := GlobalContextMap.make _ _). rewrite -(optimize_env_eq Σ'). cbn. now depelim wfg. eapply (optimize_expanded_decl_irrel (Σ := Σ')). now depelim wfg. now unshelve eapply (optimize_expanded_decl (Σ:=Σ')). Qed. -Definition disable_projections_term_flags (et : ETermFlags) := +Definition disable_projections_term_flags (et : ETermFlags) := {| has_tBox := has_tBox ; has_tRel := has_tRel ; has_tVar := has_tVar @@ -803,7 +803,7 @@ Definition disable_projections_term_flags (et : ETermFlags) := ; has_tPrim := has_tPrim |}. -Definition disable_projections_env_flag (efl : EEnvFlags) := +Definition disable_projections_env_flag (efl : EEnvFlags) := {| has_axioms := efl.(@has_axioms); term_switches := disable_projections_term_flags term_switches; has_cstr_params := efl.(@has_cstr_params) ; @@ -811,7 +811,7 @@ Definition disable_projections_env_flag (efl : EEnvFlags) := Lemma optimize_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : has_tBox -> has_tRel -> - wf_glob Σ -> EWellformed.wellformed Σ n t -> + wf_glob Σ -> EWellformed.wellformed Σ n t -> EWellformed.wellformed (efl := disable_projections_env_flag efl) Σ n (optimize Σ t). Proof. intros hbox hrel wfΣ. @@ -819,12 +819,12 @@ Proof. all:try solve [cbn; rtoProp; intuition auto; solve_all]. - cbn -[lookup_constructor_pars_args]. intros. rtoProp. repeat split; eauto. destruct cstr_as_blocks; rtoProp; eauto. - destruct lookup_constructor_pars_args as [ [] | ]; eauto. split; len. solve_all. split; eauto. + destruct lookup_constructor_pars_args as [ [] | ]; eauto. split; len. solve_all. split; eauto. solve_all. now destruct args; invs H0. - cbn. move/andP => [] /andP[] hast hl wft. rewrite GlobalContextMap.lookup_projection_spec. destruct lookup_projection as [[[[mdecl idecl] cdecl] pdecl]|] eqn:hl'; auto => //. - simpl. + simpl. rewrite (lookup_constructor_lookup_inductive (lookup_projection_lookup_constructor hl')) /=. rewrite hrel IHt //= andb_true_r. have hargs' := wellformed_projection_args wfΣ hl'. @@ -839,7 +839,7 @@ Import EWellformed. Lemma optimize_wellformed_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} t : wf_glob Σ -> - forall n, wellformed (efl := disable_projections_env_flag efl) Σ n t -> + forall n, wellformed (efl := disable_projections_env_flag efl) Σ n t -> wellformed (efl := disable_projections_env_flag efl) (optimize_env Σ) n t. Proof. intros wfΣ. induction t using EInduction.term_forall_list_ind; cbn => //. @@ -863,7 +863,7 @@ Qed. Lemma optimize_wellformed_decl_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : wf_glob Σ -> - wf_global_decl (efl:= disable_projections_env_flag efl) Σ d -> + wf_global_decl (efl:= disable_projections_env_flag efl) Σ d -> wf_global_decl (efl := disable_projections_env_flag efl) (optimize_env Σ) d. Proof. intros wf; destruct d => /= //. @@ -872,8 +872,8 @@ Proof. Qed. Lemma optimize_decl_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : - has_tBox -> has_tRel -> wf_glob Σ -> - forall d, wf_global_decl Σ d -> + has_tBox -> has_tRel -> wf_glob Σ -> + forall d, wf_global_decl Σ d -> wf_global_decl (efl := disable_projections_env_flag efl) (optimize_env Σ) (optimize_decl Σ d). Proof. intros hasb hasr wf d. @@ -885,7 +885,7 @@ Proof. intros hwf. eapply optimize_wellformed => //. Qed. -Lemma fresh_global_optimize_env {Σ : GlobalContextMap.t} kn : +Lemma fresh_global_optimize_env {Σ : GlobalContextMap.t} kn : fresh_global kn Σ -> fresh_global kn (optimize_env Σ). Proof. @@ -895,7 +895,7 @@ Proof. Qed. Lemma optimize_env_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : - has_tBox -> has_tRel -> + has_tBox -> has_tRel -> wf_glob Σ -> wf_glob (efl := disable_projections_env_flag efl) (optimize_env Σ). Proof. intros hasb hasrel. diff --git a/erasure/theories/ELiftSubst.v b/erasure/theories/ELiftSubst.v index bb4f9feea..fae9cb614 100644 --- a/erasure/theories/ELiftSubst.v +++ b/erasure/theories/ELiftSubst.v @@ -19,7 +19,7 @@ Fixpoint lift n k t : term := | tApp u v => tApp (lift n k u) (lift n k v) | tLetIn na b b' => tLetIn na (lift n k b) (lift n (S k) b') | tCase ind c brs => - let brs' := List.map (fun br => + let brs' := List.map (fun br => (br.1, lift n (#|br.1| + k) br.2)) brs in tCase ind (lift n k c) brs' | tProj p c => tProj p (lift n k c) @@ -108,7 +108,7 @@ Require Import PeanoNat. Import Nat. Lemma lift_rel_ge : - forall k n p, p <= n -> lift k p (tRel n) = tRel (k + n). + forall k n p, p <= n -> lift k p (tRel n) = tRel (k + n). Proof. intros; simpl in |- *. now elim (leb_spec p n). @@ -452,7 +452,7 @@ Proof. revert H. elim (Nat.ltb_spec n0 k); intros; try easy. - cbn. f_equal; auto. rtoProp; solve_all. - rtoProp; solve_all. + rtoProp; solve_all. destruct x; f_equal; cbn in *. eauto. Qed. @@ -489,7 +489,7 @@ Proof. rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; unfold test_def in *; simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. - - cbn. + - cbn. revert H. elim (Nat.ltb_spec n0 k); intros; try easy. elim (Nat.leb_spec k n0); intros; try easy. - cbn. f_equal; auto. @@ -574,7 +574,7 @@ Qed. Set SsrRewrite. Lemma closedn_subst_eq s k k' t : - forallb (closedn k) s -> + forallb (closedn k) s -> closedn (k + k' + #|s|) t = closedn (k + k') (subst s k' t). Proof. @@ -602,7 +602,7 @@ Proof. - eapply All_forallb_eq_forallb; tea; eauto. - specialize (IHt (S k')). rewrite <- Nat.add_succ_comm in IHt. - rewrite IHt //. + rewrite IHt //. - specialize (IHt2 (S k')). rewrite <- Nat.add_succ_comm in IHt2. rewrite IHt1 // IHt2 //. @@ -620,8 +620,8 @@ Proof. now rewrite !Nat.add_assoc !(Nat.add_comm k) in H |- *. Qed. -Lemma closedn_subst s k t : - forallb (closedn k) s -> closedn (#|s| + k) t -> +Lemma closedn_subst s k t : + forallb (closedn k) s -> closedn (#|s| + k) t -> closedn k (subst0 s t). Proof. intros. diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v index db714fe13..b16b33853 100644 --- a/erasure/theories/EOptimizePropDiscr.v +++ b/erasure/theories/EOptimizePropDiscr.v @@ -48,7 +48,7 @@ Section optimize. | _ => tCase ind (optimize c) brs' end | tProj p c => - match GlobalContextMap.inductive_isprop_and_pars Σ p.(proj_ind) with + match GlobalContextMap.inductive_isprop_and_pars Σ p.(proj_ind) with | Some (true, _) => tBox | _ => tProj p (optimize c) end @@ -75,7 +75,7 @@ Section optimize. Proof using Type. now induction n; simpl; auto; rewrite IHn. Qed. - + Lemma map_optimize_repeat_box n : map optimize (repeat tBox n) = repeat tBox n. Proof using Type. by rewrite map_repeat. Qed. @@ -107,7 +107,7 @@ Section optimize. rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; unfold test_def in *; simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. - - move/andP: H => [] clt cll. + - move/andP: H => [] clt cll. destruct GlobalContextMap.inductive_isprop_and_pars as [[[|] _]|] => /= //. destruct l as [|[br n] [|l']] eqn:eql; simpl. rewrite IHt //. @@ -123,10 +123,10 @@ Section optimize. rtoProp; solve_all. solve_all. - destruct GlobalContextMap.inductive_isprop_and_pars as [[[|] _]|]; cbn; auto. Qed. - - Lemma subst_csubst_comm l t k b : + + Lemma subst_csubst_comm l t k b : forallb (closedn 0) l -> closed t -> - subst l 0 (csubst t (#|l| + k) b) = + subst l 0 (csubst t (#|l| + k) b) = csubst t k (subst l 0 b). Proof using Type. intros hl cl. @@ -134,10 +134,10 @@ Section optimize. rewrite distr_subst. f_equal. symmetry. solve_all. rewrite subst_closed //. - eapply closed_upwards; tea. lia. + eapply closed_upwards; tea. lia. Qed. - Lemma substl_subst s t : + Lemma substl_subst s t : forallb (closedn 0) s -> substl s t = subst s 0 t. Proof using Type. @@ -149,9 +149,9 @@ Section optimize. rewrite closed_subst //. now eapply IHs. Qed. - Lemma substl_csubst_comm l t k b : + Lemma substl_csubst_comm l t k b : forallb (closedn 0) l -> closed t -> - substl l (csubst t (#|l| + k) b) = + substl l (csubst t (#|l| + k) b) = csubst t k (substl l b). Proof using Type. intros hl cl. @@ -160,12 +160,12 @@ Section optimize. apply subst_csubst_comm => //. Qed. - Lemma optimize_csubst a k b : + Lemma optimize_csubst a k b : closed a -> optimize (ECSubst.csubst a k b) = ECSubst.csubst (optimize a) k (optimize b). Proof using Type. induction b in k |- * using EInduction.term_forall_list_ind; simpl; auto; - intros cl; try easy; + intros cl; try easy; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; unfold test_def in *; simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. @@ -193,7 +193,7 @@ Section optimize. now rewrite IHb. Qed. - Lemma optimize_substl s t : + Lemma optimize_substl s t : forallb (closedn 0) s -> optimize (substl s t) = substl (map optimize s) (optimize t). Proof using Type. @@ -213,7 +213,7 @@ Section optimize. rewrite forallb_rev forallb_skipn //. now rewrite map_rev map_skipn. Qed. - + Lemma optimize_fix_subst mfix : EGlobalEnv.fix_subst (map (map_def optimize) mfix) = map optimize (EGlobalEnv.fix_subst mfix). Proof using Type. unfold EGlobalEnv.fix_subst. @@ -232,7 +232,7 @@ Section optimize. f_equal; auto. Qed. - Lemma optimize_cunfold_fix mfix idx n f : + Lemma optimize_cunfold_fix mfix idx n f : forallb (closedn 0) (EGlobalEnv.fix_subst mfix) -> cunfold_fix mfix idx = Some (n, f) -> cunfold_fix (map (map_def optimize) mfix) idx = Some (n, optimize f). @@ -246,7 +246,7 @@ Section optimize. discriminate. Qed. - Lemma optimize_cunfold_cofix mfix idx n f : + Lemma optimize_cunfold_cofix mfix idx n f : forallb (closedn 0) (EGlobalEnv.cofix_subst mfix) -> cunfold_cofix mfix idx = Some (n, f) -> cunfold_cofix (map (map_def optimize) mfix) idx = Some (n, optimize f). @@ -260,7 +260,7 @@ Section optimize. discriminate. Qed. - Lemma optimize_nth {n l d} : + Lemma optimize_nth {n l d} : optimize (nth n l d) = nth n (map optimize l) (optimize d). Proof using Type. induction l in n |- *; destruct n; simpl; auto. @@ -289,7 +289,7 @@ Proof. - rewrite is_box_tApp. move/IHev1 => ?. subst. cbn in i. destruct EWcbvEval.with_guarded_fix => //. - destruct t => //. -Qed. +Qed. Lemma isType_tSort {cf:checker_flags} {Σ : global_env_ext} {Γ l A} {wfΣ : wf Σ} : Σ ;;; Γ |- tSort (Universe.make l) : A -> isType Σ Γ (tSort (Universe.make l)). Proof. @@ -298,8 +298,8 @@ Proof. eexists; econstructor; eauto. Qed. -Lemma isType_it_mkProd {cf:checker_flags} {Σ : global_env_ext} {Γ na dom codom A} {wfΣ : wf Σ} : - Σ ;;; Γ |- tProd na dom codom : A -> +Lemma isType_it_mkProd {cf:checker_flags} {Σ : global_env_ext} {Γ na dom codom A} {wfΣ : wf Σ} : + Σ ;;; Γ |- tProd na dom codom : A -> isType Σ Γ (tProd na dom codom). Proof. intros HT. @@ -307,33 +307,33 @@ Proof. eexists; econstructor; eauto. Qed. -Definition optimize_constant_decl Σ cb := +Definition optimize_constant_decl Σ cb := {| cst_body := option_map (optimize Σ) cb.(cst_body) |}. - + Definition optimize_decl Σ d := match d with | ConstantDecl cb => ConstantDecl (optimize_constant_decl Σ cb) | InductiveDecl idecl => d end. -Definition optimize_env Σ := +Definition optimize_env Σ := map (on_snd (optimize_decl Σ)) Σ.(GlobalContextMap.global_decls). - + Import EnvMap. Program Fixpoint optimize_env' Σ : EnvMap.fresh_globals Σ -> global_context := match Σ with | [] => fun _ => [] | hd :: tl => fun HΣ => - let Σg := GlobalContextMap.make tl (fresh_globals_cons_inv HΣ) in - on_snd (optimize_decl Σg) hd :: optimize_env' tl (fresh_globals_cons_inv HΣ) + let Σg := GlobalContextMap.make tl (fresh_globals_cons_inv HΣ) in + on_snd (optimize_decl Σg) hd :: optimize_env' tl (fresh_globals_cons_inv HΣ) end. Import EGlobalEnv EExtends. -(* Lemma extends_is_propositional {Σ Σ'} : +(* Lemma extends_is_propositional {Σ Σ'} : wf_glob Σ' -> extends Σ Σ' -> - forall ind, + forall ind, match inductive_isprop_and_pars Σ ind with | Some b => inductive_isprop_and_pars Σ' ind = Some b | None => inductive_isprop_and_pars Σ' ind = None @@ -347,7 +347,7 @@ Proof. Qed. *) Lemma extends_inductive_isprop_and_pars {efl : EEnvFlags} {Σ Σ' ind} : extends Σ Σ' -> wf_glob Σ' -> - isSome (lookup_inductive Σ ind) -> + isSome (lookup_inductive Σ ind) -> inductive_isprop_and_pars Σ ind = inductive_isprop_and_pars Σ' ind. Proof. intros ext wf; cbn. @@ -357,7 +357,7 @@ Proof. destruct nth_error => //. Qed. -Lemma wellformed_optimize_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : +Lemma wellformed_optimize_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : forall n, EWellformed.wellformed Σ n t -> forall {Σ' : GlobalContextMap.t}, extends Σ Σ' -> wf_glob Σ' -> optimize Σ t = optimize Σ' t. @@ -365,7 +365,7 @@ Proof. induction t using EInduction.term_forall_list_ind; cbn -[lookup_constant lookup_inductive lookup_projection GlobalContextMap.inductive_isprop_and_pars]; intros => //. - all:unfold wf_fix_gen in *; rtoProp; intuition auto. + all:unfold wf_fix_gen in *; rtoProp; intuition auto. all:try now f_equal; eauto; solve_all. - destruct cstr_as_blocks; rtoProp; eauto. f_equal. solve_all. destruct args; inv H2. reflexivity. - rewrite !GlobalContextMap.inductive_isprop_and_pars_spec. @@ -384,7 +384,7 @@ Proof. all:f_equal; eauto. Qed. -Lemma wellformed_optimize_decl_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : +Lemma wellformed_optimize_decl_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : wf_global_decl Σ t -> forall {Σ' : GlobalContextMap.t}, extends Σ Σ' -> wf_glob Σ' -> optimize_decl Σ t = optimize_decl Σ' t. @@ -395,10 +395,10 @@ Proof. now eapply wellformed_optimize_extends. Qed. -Lemma lookup_env_optimize_env_Some {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn d : +Lemma lookup_env_optimize_env_Some {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn d : wf_glob Σ -> GlobalContextMap.lookup_env Σ kn = Some d -> - ∑ Σ' : GlobalContextMap.t, + ∑ Σ' : GlobalContextMap.t, [× extends Σ' Σ, wf_global_decl Σ' d & lookup_env (optimize_env Σ) kn = Some (optimize_decl Σ' d)]. Proof. @@ -413,7 +413,7 @@ Proof. cbn. now depelim wfg. f_equal. symmetry. eapply wellformed_optimize_decl_extends. cbn. now depelim wfg. cbn. now exists [a]. now cbn. - - intros _. + - intros _. set (Σ' := GlobalContextMap.make Σ (fresh_globals_cons_inv wf)). specialize (IHΣ (GlobalContextMap.map Σ') (GlobalContextMap.repr Σ') (GlobalContextMap.wf Σ')). cbn in IHΣ. forward IHΣ. now depelim wfg. @@ -436,7 +436,7 @@ Proof. case: eqb_spec => //. Qed. -Lemma lookup_env_optimize_env_None {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : +Lemma lookup_env_optimize_env_None {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : GlobalContextMap.lookup_env Σ kn = None -> lookup_env (optimize_env Σ) kn = None. Proof. @@ -445,7 +445,7 @@ Proof. cbn. intros hl. rewrite lookup_env_map_snd hl //. Qed. -Lemma lookup_env_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : +Lemma lookup_env_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} kn : wf_glob Σ -> lookup_env (optimize_env Σ) kn = option_map (optimize_decl Σ) (lookup_env Σ kn). Proof. @@ -455,11 +455,11 @@ Proof. - eapply lookup_env_optimize_env_Some in hl as [Σ' [ext wf' hl']] => /=. rewrite hl'. f_equal. eapply wellformed_optimize_decl_extends; eauto. auto. - - - cbn. now eapply lookup_env_optimize_env_None in hl. + + - cbn. now eapply lookup_env_optimize_env_None in hl. Qed. -Lemma is_propositional_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind : +Lemma is_propositional_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind : wf_glob Σ -> inductive_isprop_and_pars Σ ind = inductive_isprop_and_pars (optimize_env Σ) ind. Proof. @@ -467,11 +467,11 @@ Proof. rewrite /lookup_inductive /lookup_minductive. rewrite (lookup_env_optimize (inductive_mind ind) wf). rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive - /GlobalContextMap.lookup_minductive. + /GlobalContextMap.lookup_minductive. destruct lookup_env as [[decl|]|] => //. Qed. -Lemma is_propositional_cstr_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind c : +Lemma is_propositional_cstr_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind c : wf_glob Σ -> constructor_isprop_pars_decl Σ ind c = constructor_isprop_pars_decl (optimize_env Σ) ind c. Proof. @@ -479,7 +479,7 @@ Proof. rewrite /lookup_constructor /lookup_inductive /lookup_minductive. rewrite (lookup_env_optimize (inductive_mind ind) wf). rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive - /GlobalContextMap.lookup_minductive. + /GlobalContextMap.lookup_minductive. destruct lookup_env as [[decl|]|] => //. Qed. @@ -515,7 +515,7 @@ Proof. Qed. Lemma constructor_isprop_pars_decl_inductive {Σ ind c} {prop pars cdecl} : - constructor_isprop_pars_decl Σ ind c = Some (prop, pars, cdecl) -> + constructor_isprop_pars_decl Σ ind c = Some (prop, pars, cdecl) -> inductive_isprop_and_pars Σ ind = Some (prop, pars). Proof. rewrite /constructor_isprop_pars_decl /inductive_isprop_and_pars /lookup_constructor. @@ -560,14 +560,14 @@ Proof. eapply closed_iota_red => //; tea. eapply nth_error_forallb in clbrs; tea. cbn in clbrs. now rewrite Nat.add_0_r in clbrs. - + - congruence. - + - move/andP => [] cld clbrs. rewrite GlobalContextMap.inductive_isprop_and_pars_spec. rewrite e0 e1 /=. subst brs. cbn in clbrs. rewrite Nat.add_0_r andb_true_r in clbrs. - rewrite optimize_substl in IHev2. + rewrite optimize_substl in IHev2. eapply All_forallb, All_repeat => //. rewrite map_optimize_repeat_box in IHev2. apply IHev2. @@ -598,8 +598,8 @@ Proof. simpl in *. eapply Ee.eval_fix_value. auto. auto. auto. eapply optimize_cunfold_fix; eauto. eapply closed_fix_subst => //. - now rewrite map_length. - + now rewrite map_length. + - move/andP => [] clf cla. eapply eval_closed in ev1 => //. eapply eval_closed in ev2; tas. @@ -633,7 +633,7 @@ Proof. apply optimize_cunfold_cofix; tea. eapply closed_cofix_subst; tea. eapply Ee.eval_cofix_case; tea. apply optimize_cunfold_cofix; tea. eapply closed_cofix_subst; tea. - + - intros cd. specialize (IHev1 cd). move: (eval_closed _ clΣ _ _ cd ev1). rewrite closedn_mkApps; move/andP => [] clfix clargs. forward IHev2. @@ -646,7 +646,7 @@ Proof. rewrite -> optimize_mkApps in IHev1, IHev2. simpl in *. econstructor; eauto. apply optimize_cunfold_cofix; tea. eapply closed_cofix_subst; tea. - + - rewrite /declared_constant in isdecl. move: (lookup_env_optimize c wfΣ). rewrite isdecl /= //. @@ -655,7 +655,7 @@ Proof. apply IHev. eapply lookup_env_closed in clΣ; tea. move: clΣ. rewrite /closed_decl e //. - + - move=> cld. eapply eval_closed in ev1; tea. move: ev1; rewrite closedn_mkApps /= => clargs. @@ -691,20 +691,20 @@ Proof. destruct ev1; simpl in *; eauto. * destruct t => //; rewrite optimize_mkApps /=. * destruct with_guarded_fix. - + move: i. + + move: i. rewrite !negb_or. rewrite optimize_mkApps !isFixApp_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //. rewrite !andb_true_r. rtoProp; intuition auto. - destruct v => /= //. destruct v => /= //. destruct v => /= //. - + move: i. + destruct v => /= //. + + move: i. rewrite !negb_or. rewrite optimize_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //. - destruct v => /= //. + destruct v => /= //. - destruct t => //. all:constructor; eauto. cbn [atom optimize] in i |- *. rewrite -lookup_constructor_optimize //. destruct l => //. @@ -755,7 +755,7 @@ Proof. eapply expanded_tConstruct_app. destruct H as [[H ?] ?]. split => //. split => //. red. - red in H. rewrite lookup_env_optimize // /= H //. 1-2:eauto. auto. solve_all. + red in H. rewrite lookup_env_optimize // /= H //. 1-2:eauto. auto. solve_all. Qed. Lemma optimize_expanded_decl {Σ : GlobalContextMap.t} t : expanded_decl Σ t -> expanded_decl Σ (optimize_decl Σ t). @@ -772,9 +772,9 @@ Proof. apply optimize_expanded_irrel. Qed. -Lemma optimize_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : +Lemma optimize_env_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : extends Σ Σ' -> - wf_glob Σ' -> + wf_glob Σ' -> List.map (on_snd (optimize_decl Σ)) Σ.(GlobalContextMap.global_decls) = List.map (on_snd (optimize_decl Σ')) Σ.(GlobalContextMap.global_decls). Proof. @@ -823,7 +823,7 @@ Proof. clear map repr. induction 1; cbn; constructor; auto. cbn in IHexpanded_global_declarations. - unshelve eapply IHexpanded_global_declarations. now depelim wfg. cbn. + unshelve eapply IHexpanded_global_declarations. now depelim wfg. cbn. set (Σ' := GlobalContextMap.make _ _). rewrite -(optimize_env_eq Σ'). cbn. now depelim wfg. eapply (optimize_expanded_decl_irrel (Σ := Σ')). now depelim wfg. @@ -902,7 +902,7 @@ Proof. Qed. Lemma optimize_decl_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : - has_tBox -> has_tRel -> wf_glob Σ -> + has_tBox -> has_tRel -> wf_glob Σ -> forall d, wf_global_decl Σ d -> wf_global_decl (optimize_env Σ) (optimize_decl Σ d). Proof. intros hasb hasr wf d. @@ -914,7 +914,7 @@ Proof. now eapply optimize_wellformed => //. Qed. -Lemma fresh_global_optimize_env {Σ : GlobalContextMap.t} kn : +Lemma fresh_global_optimize_env {Σ : GlobalContextMap.t} kn : fresh_global kn Σ -> fresh_global kn (optimize_env Σ). Proof. @@ -924,7 +924,7 @@ Proof. Qed. Lemma optimize_env_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : - has_tBox -> has_tRel -> + has_tBox -> has_tRel -> wf_glob Σ -> wf_glob (optimize_env Σ). Proof. intros hasb hasrel. diff --git a/erasure/theories/EPretty.v b/erasure/theories/EPretty.v index 049ba801b..0fde80ad8 100644 --- a/erasure/theories/EPretty.v +++ b/erasure/theories/EPretty.v @@ -121,7 +121,7 @@ Module PrintTermTree. match lookup_ind_decl Σ i k with | Some oib => match nth_error oib.(ind_ctors) l with - | Some cstr => + | Some cstr => match args with | [] => cstr.(cstr_name) | args => parens (top || inapp) (cstr.(cstr_name) ^ "[" ^ print_list (print_term Γ false false) " " args ^ "]") @@ -137,8 +137,8 @@ Module PrintTermTree. | Some oib => let fix print_args Γ nas br {struct nas} := match nas with - | [] => "=>" ^ " " ^ br Γ - | na :: nas => + | [] => "=>" ^ " " ^ br Γ + | na :: nas => string_of_name na ^ " " ^ print_args (vass na :: Γ) nas br end in @@ -157,7 +157,7 @@ Module PrintTermTree. | Some (mdecl, idecl, cdecl, pdecl) => print_term Γ false false c ^ ".(" ^ pdecl.(proj_name) ^ ")" | None => - "UnboundProj(" ^ string_of_inductive p.(proj_ind) ^ "," ^ string_of_nat p.(proj_npars) + "UnboundProj(" ^ string_of_inductive p.(proj_ind) ^ "," ^ string_of_nat p.(proj_npars) ^ "," ^ string_of_nat p.(proj_arg) ^ "," ^ print_term Γ true false c ^ ")" end @@ -182,7 +182,7 @@ Module PrintTermTree. end. Definition pr_allowed_elim (elims : Universes.allowed_eliminations) := - match elims with + match elims with | Universes.IntoSProp => "into sprop" | Universes.IntoPropSProp => "into prop or sprop" | Universes.IntoSetPropSProp => "into set, prop or sprop" @@ -193,12 +193,12 @@ Module PrintTermTree. let params := string_of_nat npars ^ " parameters" in let prop := if body.(ind_propositional) then "propositional" else "computational" in let kelim := pr_allowed_elim body.(ind_kelim) in - let ctors := print_list (fun cstr => "| " ^ (cstr.(cstr_name) : ident) ^ " " ^ + let ctors := print_list (fun cstr => "| " ^ (cstr.(cstr_name) : ident) ^ " " ^ string_of_nat cstr.(cstr_nargs) ^ " arguments") nl body.(ind_ctors) in let projs := match body.(ind_projs) return Tree.t with | [] => "" - | _ => nl ^ "projections: " ^ print_list (fun x => x.(proj_name)) ", " body.(ind_projs) + | _ => nl ^ "projections: " ^ print_list (fun x => x.(proj_name)) ", " body.(ind_projs) end in body.(ind_name) ^ "(" ^ params ^ "," ^ prop ^ ", elimination " ^ kelim ^ ") := " ^ nl ^ ctors ^ projs. @@ -214,17 +214,17 @@ Module PrintTermTree. print_recursivity_kind decl.(ind_finite) ^ " " ^ print_list (print_one_inductive_body decl.(ind_npars)) (nl ^ " with ") decl.(ind_bodies). - Definition print_decl Σ '(kn, d) := + Definition print_decl Σ '(kn, d) := match d with | ConstantDecl body => print_constant_body Σ kn body | InductiveDecl mind => print_inductive_body mind end. - Definition print_global_context (g : global_context) := + Definition print_global_context (g : global_context) := print_list (print_decl g) nl (List.rev g). Notation print_env := print_global_context. - Definition print_program (p : program) : t := + Definition print_program (p : program) : t := pr p.1 p.2 ^ nl ^ "in" ^ print_env p.1. End PrintTermTree. diff --git a/erasure/theories/EProgram.v b/erasure/theories/EProgram.v index 57b37ea83..58bd2d3b8 100644 --- a/erasure/theories/EProgram.v +++ b/erasure/theories/EProgram.v @@ -25,21 +25,21 @@ Global Arguments EWcbvEval.eval {wfl} _ _ _. Definition wf_eprogram (efl : EEnvFlags) (p : eprogram) := @wf_glob efl p.1 /\ @wellformed efl p.1 0 p.2. - + Definition wf_eprogram_env (efl : EEnvFlags) (p : eprogram_env) := @wf_glob efl p.1.(global_decls) /\ @wellformed efl p.1.(global_decls) 0 p.2. -Definition eval_eprogram (wfl : EWcbvEval.WcbvFlags) (p : eprogram) (t : EAst.term) := +Definition eval_eprogram (wfl : EWcbvEval.WcbvFlags) (p : eprogram) (t : EAst.term) := ∥ EWcbvEval.eval (wfl:=wfl) p.1 p.2 t ∥. -Definition closed_eprogram (p : eprogram) := +Definition closed_eprogram (p : eprogram) := closed_env p.1 && ELiftSubst.closedn 0 p.2. -Definition closed_eprogram_env (p : eprogram_env) := +Definition closed_eprogram_env (p : eprogram_env) := let Σ := p.1.(global_decls) in closed_env Σ && ELiftSubst.closedn 0 p.2. -Definition eval_eprogram_env (wfl : EWcbvEval.WcbvFlags) (p : eprogram_env) (t : EAst.term) := +Definition eval_eprogram_env (wfl : EWcbvEval.WcbvFlags) (p : eprogram_env) (t : EAst.term) := ∥ EWcbvEval.eval (wfl:=wfl) p.1.(global_decls) p.2 t ∥. Import EWellformed. @@ -49,4 +49,4 @@ Proof. induction Σ. constructor; auto. intros wf; depelim wf. constructor; auto. Qed. - + diff --git a/erasure/theories/EReflect.v b/erasure/theories/EReflect.v index a0721b9af..736eb85f3 100644 --- a/erasure/theories/EReflect.v +++ b/erasure/theories/EReflect.v @@ -123,7 +123,7 @@ Definition eqb_constant_body (x y : constant_body) := eqb (cst_body x) (cst_body y). #[global, program] -Instance reflect_constant_body : ReflectEq constant_body := +Instance reflect_constant_body : ReflectEq constant_body := {| eqb := eqb_constant_body |}. Next Obligation. Proof. @@ -137,7 +137,7 @@ Definition eqb_constructor_body (x y : constructor_body) := (x.(cstr_name), x.(cstr_nargs)) == (y.(cstr_name), y.(cstr_nargs)). #[global, program] -Instance reflect_constructor_body : ReflectEq constructor_body := +Instance reflect_constructor_body : ReflectEq constructor_body := {| eqb := eqb_constructor_body |}. Next Obligation. Proof. @@ -149,7 +149,7 @@ Definition eqb_projection_body (x y : projection_body) := x.(proj_name) == y.(proj_name). #[global, program] -Instance reflect_projection_body : ReflectEq projection_body := +Instance reflect_projection_body : ReflectEq projection_body := {| eqb := eqb_projection_body |}. Next Obligation. Proof. @@ -177,9 +177,9 @@ Definition eqb_mutual_inductive_body (x y : mutual_inductive_body) := eqb f f' && eqb n n' && eqb b b'. #[global, program] -Instance reflect_mutual_inductive_body : ReflectEq mutual_inductive_body := +Instance reflect_mutual_inductive_body : ReflectEq mutual_inductive_body := {| eqb := eqb_mutual_inductive_body |}. -Next Obligation. +Next Obligation. Proof. revert x y; intros [] []. unfold eqb_mutual_inductive_body; finish_reflect. diff --git a/erasure/theories/ERemoveParams.v b/erasure/theories/ERemoveParams.v index 21a8efb37..c0bfcf460 100644 --- a/erasure/theories/ERemoveParams.v +++ b/erasure/theories/ERemoveParams.v @@ -1,8 +1,8 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import Utf8 Program. -From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap. +From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap. From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EArities - ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap + ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap EWcbvEval EEtaExpanded ECSubst EWcbvEvalEtaInd EProgram. Local Open Scope string_scope. @@ -29,7 +29,7 @@ Section strip. Section Def. Import TermSpineView. - Equations? strip (t : term) : term + Equations? strip (t : term) : term by wf t (fun x y : EAst.term => size x < size y) := | e with TermSpineView.view e := { | tRel i => EAst.tRel i @@ -40,7 +40,7 @@ Section strip. | Some npars := mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map_InP v (fun x H => strip x))) | None => mkApps (EAst.tConstruct kn c block_args) (map_InP v (fun x H => strip x)) } - | view_other u nconstr => + | view_other u nconstr => mkApps (strip u) (map_InP v (fun x H => strip x)) } | tLetIn na b b' => EAst.tLetIn na (strip b) (strip b') @@ -75,22 +75,22 @@ Section strip. End Def. Hint Rewrite @map_InP_spec : strip. - + Lemma map_repeat {A B} (f : A -> B) x n : map f (repeat x n) = repeat (f x) n. Proof using Type. now induction n; simpl; auto; rewrite IHn. Qed. - + Lemma map_strip_repeat_box n : map strip (repeat tBox n) = repeat tBox n. Proof using Type. now rewrite map_repeat. Qed. - + Arguments eqb : simpl never. - + Opaque strip_unfold_clause_1. Opaque strip. Opaque isEtaExp. Opaque isEtaExp_unfold_clause_1. - + Lemma closedn_mkApps k f l : closedn k (mkApps f l) = closedn k f && forallb (closedn k) l. Proof using Type. induction l in f |- *; cbn; auto. @@ -109,17 +109,17 @@ Section strip. - rewrite !closedn_mkApps in H1 *. rtoProp; intuition auto. solve_all. - - rewrite !closedn_mkApps /= in H0 *. rtoProp. + - rewrite !closedn_mkApps /= in H0 *. rtoProp. rewrite forallb_skipn; solve_all. solve_all. - rewrite !closedn_mkApps /= in H0 *. rtoProp. repeat solve_all. Qed. Hint Rewrite @forallb_InP_spec : isEtaExp. Transparent isEtaExp_unfold_clause_1. - + Local Lemma strip_mkApps_nonnil f v : ~~ isApp f -> v <> [] -> - strip (mkApps f v) = match construct_viewc f with + strip (mkApps f v) = match construct_viewc f with | view_construct kn c block_args => match lookup_inductive_pars Σ (inductive_mind kn) with | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map strip v)) @@ -139,7 +139,7 @@ Section strip. Qed. Lemma strip_mkApps f v : ~~ isApp f -> - strip (mkApps f v) = match construct_viewc f with + strip (mkApps f v) = match construct_viewc f with | view_construct kn c block_args => match lookup_inductive_pars Σ (inductive_mind kn) with | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map strip v)) @@ -156,7 +156,7 @@ Section strip. - apply (strip_mkApps_nonnil f (v ++ [x])) => //. Qed. - Lemma lookup_inductive_pars_constructor_pars_args {ind n pars args} : + Lemma lookup_inductive_pars_constructor_pars_args {ind n pars args} : lookup_constructor_pars_args Σ ind n = Some (pars, args) -> lookup_inductive_pars Σ (inductive_mind ind) = Some pars. Proof using Type. @@ -165,7 +165,7 @@ Section strip. cbn. do 2 destruct nth_error => //. congruence. Qed. - Lemma strip_csubst a k b : + Lemma strip_csubst a k b : closed a -> isEtaExp Σ a -> isEtaExp Σ b -> @@ -177,7 +177,7 @@ Section strip. rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; unfold test_def in *; simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. - + - destruct Nat.compare => //. - f_equal. rtoProp. solve_all. destruct block_args; inv H0. eauto. - f_equal. solve_all. move/andP: b => [] _ he. solve_all. @@ -232,7 +232,7 @@ Section strip. subst pars. rewrite skipn_0. simp strip; rewrite -strip_equation_1. { f_equal. rewrite !map_map_compose. clear -etaa cla ev H0. solve_all. } } - - pose proof (etaExp_csubst _ _ k _ etaa H0). + - pose proof (etaExp_csubst _ _ k _ etaa H0). rewrite !csubst_mkApps /= in H1 *. assert (map (csubst a k) v <> []). { destruct v; cbn; congruence. } @@ -246,9 +246,9 @@ Section strip. f_equal. now destruct block_args; inv etav. rewrite map_skipn. f_equal. - rewrite !map_map_compose. + rewrite !map_map_compose. rewrite isEtaExp_Constructor // in H0. rtoProp. solve_all. - - pose proof (etaExp_csubst _ _ k _ etaa H0). + - pose proof (etaExp_csubst _ _ k _ etaa H0). rewrite !csubst_mkApps /= in H1 *. assert (map (csubst a k) v <> []). { destruct v; cbn; congruence. } @@ -262,7 +262,7 @@ Section strip. now rewrite (lookup_inductive_pars_constructor_pars_args eqpars) in Heq. Qed. - Lemma strip_substl s t : + Lemma strip_substl s t : forallb (closedn 0) s -> forallb (isEtaExp Σ) s -> isEtaExp Σ t -> @@ -287,7 +287,7 @@ Section strip. rewrite forallb_rev forallb_skipn //. now rewrite map_rev map_skipn. Qed. - + Lemma strip_fix_subst mfix : EGlobalEnv.fix_subst (map (map_def strip) mfix) = map strip (EGlobalEnv.fix_subst mfix). Proof using Type. unfold EGlobalEnv.fix_subst. @@ -306,7 +306,7 @@ Section strip. f_equal; auto. now simp strip. Qed. - Lemma strip_cunfold_fix mfix idx n f : + Lemma strip_cunfold_fix mfix idx n f : forallb (closedn 0) (fix_subst mfix) -> forallb (fun d => isLambda (dbody d) && isEtaExp Σ (dbody d)) mfix -> cunfold_fix mfix idx = Some (n, f) -> @@ -325,8 +325,8 @@ Section strip. discriminate. Qed. - - Lemma strip_cunfold_cofix mfix idx n f : + + Lemma strip_cunfold_cofix mfix idx n f : forallb (closedn 0) (cofix_subst mfix) -> forallb (isEtaExp Σ ∘ dbody) mfix -> cunfold_cofix mfix idx = Some (n, f) -> @@ -344,7 +344,7 @@ Section strip. discriminate. Qed. - Lemma strip_nth {n l d} : + Lemma strip_nth {n l d} : strip (nth n l d) = nth n (map strip l) (strip d). Proof using Type. induction l in n |- *; destruct n; simpl; auto. @@ -358,10 +358,10 @@ Ltac simp_eta := simp isEtaExp; rewrite -?isEtaExp_equation_1. Tactic Notation "simp_strip" "in" hyp(H) := simp strip in H; rewrite -?strip_equation_1 in H. Ltac simp_strip := simp strip; rewrite -?strip_equation_1. -Definition strip_constant_decl Σ cb := +Definition strip_constant_decl Σ cb := {| cst_body := option_map (strip Σ) cb.(cst_body) |}. - -Definition strip_inductive_decl idecl := + +Definition strip_inductive_decl idecl := {| ind_finite := idecl.(ind_finite); ind_npars := 0; ind_bodies := idecl.(ind_bodies) |}. Definition strip_decl Σ d := @@ -378,8 +378,8 @@ Definition strip_program (p : eprogram_env) : eprogram := Import EGlobalEnv. -Lemma lookup_env_strip Σ kn : - lookup_env (strip_env Σ) kn = +Lemma lookup_env_strip Σ kn : + lookup_env (strip_env Σ) kn = option_map (strip_decl Σ) (lookup_env Σ.(GlobalContextMap.global_decls) kn). Proof. unfold strip_env. @@ -388,8 +388,8 @@ Proof. case: eqb_spec => //. Qed. -Lemma lookup_constructor_strip {Σ kn c} : - lookup_constructor (strip_env Σ) kn c = +Lemma lookup_constructor_strip {Σ kn c} : + lookup_constructor (strip_env Σ) kn c = match lookup_constructor Σ.(GlobalContextMap.global_decls) kn c with | Some (mdecl, idecl, cdecl) => Some (strip_inductive_decl mdecl, idecl, cdecl) | None => None @@ -401,11 +401,11 @@ Proof. do 2 destruct nth_error => //. Qed. -Lemma is_propositional_strip (Σ : GlobalContextMap.t) ind : +Lemma is_propositional_strip (Σ : GlobalContextMap.t) ind : match inductive_isprop_and_pars Σ.(GlobalContextMap.global_decls) ind with - | Some (prop, npars) => + | Some (prop, npars) => inductive_isprop_and_pars (strip_env Σ) ind = Some (prop, 0) - | None => + | None => inductive_isprop_and_pars (strip_env Σ) ind = None end. Proof. @@ -415,11 +415,11 @@ Proof. destruct g; simpl; auto. destruct nth_error => //. Qed. -Lemma is_propositional_cstr_strip {Σ : GlobalContextMap.t} {ind c} : +Lemma is_propositional_cstr_strip {Σ : GlobalContextMap.t} {ind c} : match constructor_isprop_pars_decl Σ.(GlobalContextMap.global_decls) ind c with - | Some (prop, npars, cdecl) => + | Some (prop, npars, cdecl) => constructor_isprop_pars_decl (strip_env Σ) ind c = Some (prop, 0, cdecl) - | None => + | None => constructor_isprop_pars_decl (strip_env Σ) ind c = None end. Proof. @@ -433,13 +433,13 @@ Arguments eval {wfl}. Arguments isEtaExp : simpl never. -Lemma isEtaExp_mkApps {Σ} {f u} : isEtaExp Σ (tApp f u) -> +Lemma isEtaExp_mkApps {Σ} {f u} : isEtaExp Σ (tApp f u) -> let (hd, args) := decompose_app (tApp f u) in match construct_viewc hd with | view_construct kn c block_args => - args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ + args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ) args && is_nil block_args - | view_other _ discr => + | view_other _ discr => [&& isEtaExp Σ hd, forallb (isEtaExp Σ) args, isEtaExp Σ f & isEtaExp Σ u] end. Proof. @@ -518,7 +518,7 @@ Qed. Module Fast. Section faststrip. Context (Σ : GlobalContextMap.t). - + Equations strip (app : list term) (t : term) : term := { | app, tEvar ev args => mkApps (EAst.tEvar ev (strip_args args)) app | app, tLambda na M => mkApps (EAst.tLambda na (strip [] M)) app @@ -538,27 +538,27 @@ Module Fast. | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars app) | None => mkApps (EAst.tConstruct kn c block_args) app } | app, x => mkApps x app } - + where strip_args (t : list term) : list term := - { | [] := [] + { | [] := [] | a :: args := (strip [] a) :: strip_args args } - + where strip_brs (t : list (list BasicAst.name × term)) : list (list BasicAst.name × term) := - { | [] := [] + { | [] := [] | a :: args := (a.1, (strip [] a.2)) :: strip_brs args } - + where strip_defs (t : mfixpoint term) : mfixpoint term := { | [] := [] | d :: defs := {| dname := dname d; dbody := strip [] d.(dbody); rarg := d.(rarg) |} :: strip_defs defs }. - Local Ltac specIH := + Local Ltac specIH := match goal with | [ H : (forall args : list term, _) |- _ ] => specialize (H [] eq_refl) end. - - Lemma strip_acc_opt t : + + Lemma strip_acc_opt t : forall args, ERemoveParams.strip Σ (mkApps t args) = strip (map (ERemoveParams.strip Σ) args) t. Proof using Type. intros args. @@ -593,13 +593,13 @@ Module Fast. Proof using Type. now apply (strip_acc_opt t []). Qed. End faststrip. - + Notation strip' Σ := (strip Σ []). - Definition strip_constant_decl Σ cb := + Definition strip_constant_decl Σ cb := {| cst_body := option_map (strip' Σ) cb.(cst_body) |}. - - Definition strip_inductive_decl idecl := + + Definition strip_inductive_decl idecl := {| ind_finite := idecl.(ind_finite); ind_npars := 0; ind_bodies := idecl.(ind_bodies) |}. Definition strip_decl Σ d := @@ -633,7 +633,7 @@ Proof. rewrite mkApps_app /= //. Qed. -Lemma isBox_mkApps' f l : +Lemma isBox_mkApps' f l : l <> nil -> ~~ isBox (EAst.mkApps f l). Proof. @@ -641,7 +641,7 @@ Proof. rewrite mkApps_app /= //. Qed. -Lemma isFix_mkApps' f l : +Lemma isFix_mkApps' f l : l <> nil -> ~~ isFix (EAst.mkApps f l). Proof. @@ -649,28 +649,28 @@ Proof. rewrite mkApps_app /= //. Qed. -Lemma isLambda_mkApps_Construct ind n block_args l : +Lemma isLambda_mkApps_Construct ind n block_args l : ~~ EAst.isLambda (EAst.mkApps (EAst.tConstruct ind n block_args) l). Proof. induction l using rev_ind; cbn; try congruence. rewrite mkApps_app /= //. Qed. -Lemma isBox_mkApps_Construct ind n block_args l : +Lemma isBox_mkApps_Construct ind n block_args l : ~~ isBox (EAst.mkApps (EAst.tConstruct ind n block_args) l). Proof. induction l using rev_ind; cbn; try congruence. rewrite mkApps_app /= //. Qed. -Lemma isFix_mkApps_Construct ind n block_args l : +Lemma isFix_mkApps_Construct ind n block_args l : ~~ isFix (EAst.mkApps (EAst.tConstruct ind n block_args) l). Proof. induction l using rev_ind; cbn; try congruence. rewrite mkApps_app /= //. Qed. -Lemma strip_isLambda Σ f : +Lemma strip_isLambda Σ f : EAst.isLambda f = EAst.isLambda (strip Σ f). Proof. funelim (strip Σ f); cbn -[strip]; (try simp_strip) => //. @@ -679,7 +679,7 @@ Proof. all:rewrite !(negbTE (isLambda_mkApps_Construct _ _ _ _)) //. Qed. -Lemma strip_isBox Σ f : +Lemma strip_isBox Σ f : isBox f = isBox (strip Σ f). Proof. funelim (strip Σ f); cbn -[strip] => //. @@ -695,7 +695,7 @@ Proof. rewrite mkApps_app /= //. Qed. -Lemma strip_isApp Σ f : +Lemma strip_isApp Σ f : ~~ EAst.isApp f -> ~~ EAst.isApp (strip Σ f). Proof. @@ -704,7 +704,7 @@ Proof. all:rewrite isApp_mkApps //. Qed. -Lemma strip_isFix Σ f : +Lemma strip_isFix Σ f : isFix f = isFix (strip Σ f). Proof. funelim (strip Σ f); cbn -[strip] => //. @@ -714,7 +714,7 @@ Proof. all:rewrite !(negbTE (isFix_mkApps_Construct _ _ _ _)) //. Qed. -Lemma strip_isFixApp Σ f : +Lemma strip_isFixApp Σ f : isFixApp f = isFixApp (strip Σ f). Proof. funelim (strip Σ f); cbn -[strip] => //. @@ -722,7 +722,7 @@ Proof. all:rewrite isFixApp_mkApps isFixApp_mkApps //. Qed. -Lemma strip_isConstructApp Σ f : +Lemma strip_isConstructApp Σ f : isConstructApp f = isConstructApp (strip Σ f). Proof. funelim (strip Σ f); cbn -[strip] => //. @@ -730,7 +730,7 @@ Proof. all:rewrite isConstructApp_mkApps isConstructApp_mkApps //. Qed. -Lemma strip_isPrimApp Σ f : +Lemma strip_isPrimApp Σ f : isPrimApp f = isPrimApp (strip Σ f). Proof. funelim (strip Σ f); cbn -[strip] => //. @@ -799,7 +799,7 @@ Proof. now rewrite H1 skipn_0. + move=> /andP[] etat0 etal0. rewrite -mkApps_app !strip_mkApps; try now eapply decompose_app_notApp. - rewrite vc. rewrite -mkApps_app !map_app //. + rewrite vc. rewrite -mkApps_app !map_app //. Qed. #[export] Instance Qpreserves_closedn (efl := all_env_flags) Σ : closed_env Σ -> @@ -818,7 +818,7 @@ Proof. - red. intros kn decl. move/(lookup_env_closed clΣ). unfold closed_decl. destruct EAst.cst_body => //. - - red. move=> hasapp n t args. rewrite closedn_mkApps. + - red. move=> hasapp n t args. rewrite closedn_mkApps. split; intros; rtoProp; intuition auto; solve_all. - red. move=> hascase n ci discr brs. simpl. intros; rtoProp; intuition auto; solve_all. @@ -853,10 +853,10 @@ Proof. econstructor; eauto. - rewrite strip_tApp //. simp_strip in e1. - econstructor; eauto. + econstructor; eauto. rewrite strip_csubst // in e. now simp_eta in i10. - - simp_strip. + - simp_strip. rewrite strip_csubst // in e. econstructor; eauto. @@ -879,7 +879,7 @@ Proof. rewrite strip_iota_red // in e. rewrite closedn_mkApps in i4. now move/andP: i4. cbn. now eapply nth_error_forallb in H; tea. - + - subst brs. cbn in H4. rewrite andb_true_r in H4. rewrite strip_substl // in e. @@ -915,7 +915,7 @@ Proof. { move: i4. rewrite closedn_mkApps. now move/andP => []. } { move: i6. rewrite isEtaExp_mkApps_napp // /= => /andP[] //. now simp isEtaExp. } - now rewrite map_length. + now rewrite map_length. - rewrite strip_tApp //. simp_strip in e0. simp_strip in e1. @@ -938,7 +938,7 @@ Proof. rewrite strip_mkApps_etaexp // in e. - destruct p as [[ind pars] arg]. - simp_strip. + simp_strip. simp_strip in e. rewrite strip_mkApps // /= in e0. simp_strip in e0. @@ -949,12 +949,12 @@ Proof. { eapply closed_cofix_subst; tea. move: i4; rewrite closedn_mkApps => /andP[] //. } { move: i6. rewrite isEtaExp_mkApps_napp // /= => /andP[] //. now simp isEtaExp. } - + - econstructor. red in H |- *. rewrite lookup_env_strip H //. now rewrite /strip_constant_decl H0. exact e. - + - simp_strip. rewrite strip_mkApps // /= in e0. rewrite (constructor_isprop_pars_decl_lookup H2) in e0. @@ -971,7 +971,7 @@ Proof. move: H1. eapply contraNN. rewrite -strip_isLambda -strip_isConstructApp -strip_isFixApp -strip_isBox -strip_isPrimApp //. rewrite -strip_isFix //. - + - rewrite !strip_mkApps // /=. rewrite (lookup_constructor_lookup_inductive_pars H). eapply eval_mkApps_Construct; tea. @@ -983,7 +983,7 @@ Proof. + cbn in H0. eapply All2_skipn, All2_map. eapply All2_impl; tea; cbn -[strip]. intros x y []; auto. - + - destruct t => //. all:constructor; eauto. simp strip. cbn [atom strip] in H |- *. @@ -993,7 +993,7 @@ Qed. From MetaCoq.Erasure Require Import EEtaExpanded. -Lemma strip_declared_constructor {Σ : GlobalContextMap.t} {k mdecl idecl cdecl} : +Lemma strip_declared_constructor {Σ : GlobalContextMap.t} {k mdecl idecl cdecl} : declared_constructor Σ.(GlobalContextMap.global_decls) k mdecl idecl cdecl -> declared_constructor (strip_env Σ) k (strip_inductive_decl mdecl) idecl cdecl. Proof. @@ -1002,7 +1002,7 @@ Proof. rewrite lookup_env_strip H //. Qed. -Lemma lookup_inductive_pars_spec {Σ} {mind} {mdecl} : +Lemma lookup_inductive_pars_spec {Σ} {mind} {mdecl} : declared_minductive Σ mind mdecl -> lookup_inductive_pars Σ mind = Some (ind_npars mdecl). Proof. @@ -1013,8 +1013,8 @@ Qed. (* Stripping preserves well-formedness directly, not caring about eta-expansion *) Lemma strip_wellformed {Σ : GlobalContextMap.t} n t : - @wf_glob all_env_flags Σ -> - @wellformed all_env_flags Σ n t -> + @wf_glob all_env_flags Σ -> + @wellformed all_env_flags Σ n t -> @wellformed all_env_flags (strip_env Σ) n (strip Σ t). Proof. intros wfΣ. @@ -1102,15 +1102,15 @@ Proof. Qed. Definition switch_no_params (efl : EEnvFlags) := - {| has_axioms := has_axioms; + {| has_axioms := has_axioms; has_cstr_params := false; term_switches := term_switches ; cstr_as_blocks := false |}. Lemma strip_decl_wf (efl := all_env_flags) {Σ : GlobalContextMap.t} : - wf_glob Σ -> - forall d, wf_global_decl Σ d -> + wf_glob Σ -> + forall d, wf_global_decl Σ d -> wf_global_decl (efl := switch_no_params efl) (strip_env Σ) (strip_decl Σ d). Proof. intros wf d. @@ -1119,13 +1119,13 @@ Proof. now apply (strip_wellformed (Σ := Σ) 0 t). Qed. -Lemma fresh_global_strip_env {Σ : GlobalContextMap.t} kn : +Lemma fresh_global_strip_env {Σ : GlobalContextMap.t} kn : fresh_global kn Σ -> fresh_global kn (strip_env Σ). Proof. unfold fresh_global. cbn. unfold strip_env. induction (GlobalContextMap.global_decls Σ); cbn; constructor; auto. cbn. - now depelim H. depelim H. eauto. + now depelim H. depelim H. eauto. Qed. From MetaCoq.Erasure Require Import EProgram. @@ -1134,18 +1134,18 @@ Program Fixpoint strip_env' Σ : EnvMap.fresh_globals Σ -> global_context := match Σ with | [] => fun _ => [] | hd :: tl => fun HΣ => - let Σg := GlobalContextMap.make tl (fresh_globals_cons_inv HΣ) in - on_snd (strip_decl Σg) hd :: strip_env' tl (fresh_globals_cons_inv HΣ) + let Σg := GlobalContextMap.make tl (fresh_globals_cons_inv HΣ) in + on_snd (strip_decl Σg) hd :: strip_env' tl (fresh_globals_cons_inv HΣ) end. -Lemma lookup_minductive_declared_minductive Σ ind mdecl : +Lemma lookup_minductive_declared_minductive Σ ind mdecl : lookup_minductive Σ ind = Some mdecl <-> declared_minductive Σ ind mdecl. Proof. unfold declared_minductive, lookup_minductive. destruct lookup_env => /= //. destruct g => /= //; split => //; congruence. Qed. -Lemma lookup_minductive_declared_inductive Σ ind mdecl idecl : +Lemma lookup_minductive_declared_inductive Σ ind mdecl idecl : lookup_inductive Σ ind = Some (mdecl, idecl) <-> declared_inductive Σ ind mdecl idecl. Proof. unfold declared_inductive, lookup_inductive. @@ -1160,7 +1160,7 @@ Qed. Lemma extends_lookup_inductive_pars {efl : EEnvFlags} {Σ Σ'} : extends Σ Σ' -> wf_glob Σ' -> - forall ind t, lookup_inductive_pars Σ ind = Some t -> + forall ind t, lookup_inductive_pars Σ ind = Some t -> lookup_inductive_pars Σ' ind = Some t. Proof. intros ext wf ind t. @@ -1211,10 +1211,10 @@ Proof. intros _ => //. Qed. -Lemma strip_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : +Lemma strip_extends' {efl : EEnvFlags} {Σ Σ' : GlobalContextMap.t} : has_tApp -> extends Σ Σ' -> - wf_glob Σ' -> + wf_glob Σ' -> List.map (on_snd (strip_decl Σ)) Σ.(GlobalContextMap.global_decls) = List.map (on_snd (strip_decl Σ')) Σ.(GlobalContextMap.global_decls). Proof. @@ -1327,7 +1327,7 @@ Proof. - constructor; auto. - set (Σ' := GlobalContextMap.make Σ (fresh_globals_cons_inv wf')). constructor; auto. - eapply IHexp. eapply Σ'. now depelim wf. cbn. + eapply IHexp. eapply Σ'. now depelim wf. cbn. eapply (strip_expanded_decl (Σ := Σ')) in H. rewrite -(strip_env_eq Σ'). cbn. now depelim wf. exact H. diff --git a/erasure/theories/ESpineView.v b/erasure/theories/ESpineView.v index 219591aec..f3bae987a 100644 --- a/erasure/theories/ESpineView.v +++ b/erasure/theories/ESpineView.v @@ -27,8 +27,8 @@ Derive Signature for t. Definition view : forall x : term, t x := MkAppsInd.case (P:=fun x => t x) - tBox tRel tVar - (fun n l => tEvar n l) + tBox tRel tVar + (fun n l => tEvar n l) (fun n t => tLambda n t) (fun n b t => tLetIn n b t) (fun f l napp nnil => tApp f l napp nnil) @@ -40,7 +40,7 @@ Definition view : forall x : term, t x := (fun mfix n => tCoFix mfix n) (fun p => tPrim p). -Lemma view_mkApps {f v} (vi : t (mkApps f v)) : ~~ isApp f -> v <> [] -> +Lemma view_mkApps {f v} (vi : t (mkApps f v)) : ~~ isApp f -> v <> [] -> exists hf vn, vi = tApp f v hf vn. Proof. intros ha hv. @@ -50,5 +50,5 @@ Proof. epose proof (DepElim.pr2_uip (A:=EAst.term) He). subst vi0. do 2 eexists; reflexivity. Qed. - + End TermSpineView. \ No newline at end of file diff --git a/erasure/theories/ESubstitution.v b/erasure/theories/ESubstitution.v index cec68e81e..3fd8feeb2 100644 --- a/erasure/theories/ESubstitution.v +++ b/erasure/theories/ESubstitution.v @@ -2,7 +2,7 @@ From Coq Require Import Program ssreflect. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICLiftSubst PCUICTyping - PCUICGlobalEnv PCUICWeakeningConv PCUICWeakeningTyp PCUICSubstitution + PCUICGlobalEnv PCUICWeakeningConv PCUICWeakeningTyp PCUICSubstitution PCUICWeakeningEnv PCUICWeakeningEnvTyp PCUICOnFreeVars PCUICElimination. From MetaCoq.Erasure Require Import EGlobalEnv Extract Prelim. @@ -84,7 +84,7 @@ Proof. destruct isdecl as [decli declc]. eapply PCUICWeakeningEnv.weakening_env_declared_inductive in decli; tea; eauto; tc. now rewrite (PCUICAst.declared_inductive_lookup decli). - - econstructor. all:eauto. + - econstructor. all:eauto. eapply Informative_extends; eauto. eapply All2i_All2_All2; tea. cbv beta. intros n cdecl br br'. @@ -138,12 +138,12 @@ Proof. intros. now subst. Qed. -Lemma lift_inst_case_branch_context (Γ'' Γ' : context) p br : +Lemma lift_inst_case_branch_context (Γ'' Γ' : context) p br : test_context_k (fun k : nat => on_free_vars (closedP k xpredT)) #|pparams p| (bcontext br) -> inst_case_branch_context (map_predicate_k id (lift #|Γ''|) #|Γ'| p) - (map_branch_k (lift #|Γ''|) id #|Γ'| br) = + (map_branch_k (lift #|Γ''|) id #|Γ'| br) = lift_context #|Γ''| #|Γ'| (inst_case_branch_context p br). Proof. intros hctx. @@ -203,7 +203,7 @@ Proof. - econstructor. + eauto. + eapply H4; eauto. - + red in H6. + + red in H6. eapply Forall2_All2 in H6. eapply All2i_All2_mix_left in X6; tea. clear H6. @@ -212,9 +212,9 @@ Proof. eapply All2i_All2_All2; tea; cbv beta. intros n cdecl br br'. intros (hnth & ? & ? & ? & (? & ?) & ? & ?) []. split => //. - rewrite lift_inst_case_branch_context //. + rewrite lift_inst_case_branch_context //. { rewrite test_context_k_closed_on_free_vars_ctx. - eapply alpha_eq_on_free_vars. symmetry; tea. + eapply alpha_eq_on_free_vars. symmetry; tea. rewrite -closedn_ctx_on_free_vars. rewrite (wf_predicate_length_pars H0). rewrite (declared_minductive_ind_npars isdecl). @@ -236,7 +236,7 @@ Proof. destruct X4; cbn in *; pcuicfo. exists x0; auto. eapply (All_impl X1). intros d [HT IH]. pcuicfo. - + eapply weakening_typing in HT; auto. 2:{ apply All_local_env_app_inv in X2 as [X2 _]. eapply X2. } @@ -270,7 +270,7 @@ Proof. destruct X4; cbn in *; pcuicfo. now exists x0. eapply (All_impl X1). intros d [HT IH]. pcuicfo. - + eapply weakening_typing in HT; auto. 2:{ apply All_local_env_app_inv in X2 as [X2 _]. eapply X2. } @@ -351,8 +351,8 @@ Proof. Qed. Lemma subst_case_branch_context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} ind (n : nat) mdecl idecl p br cdecl s k : - PCUICAst.declared_constructor Σ (ind, n) mdecl idecl cdecl -> - wf_predicate mdecl idecl p -> + PCUICAst.declared_constructor Σ (ind, n) mdecl idecl cdecl -> + wf_predicate mdecl idecl p -> All2 (PCUICEquality.compare_decls eq eq) (bcontext br) (cstr_branch_context ind mdecl cdecl) -> subst_context s k (case_branch_context ind mdecl p (forget_types (bcontext br)) cdecl) = @@ -457,7 +457,7 @@ Proof. eapply All2_impl_In; eauto. intros. destruct H11, x, y. cbn in e0. subst. split; eauto. eapply In_nth_error in H9 as []. - move: H6. rewrite /wf_branches. + move: H6. rewrite /wf_branches. move/Forall2_All2 => hbrs. eapply All2_nth_error_Some_r in hbrs; tea. set (br := {| bcontext := _ |}). @@ -509,7 +509,7 @@ Proof. eapply All2_map. eapply All2_impl_In. eassumption. - intros. destruct H4 as [? ? ? ?]. + intros. destruct H4 as [? ? ? ?]. repeat split; eauto. cbn. now eapply isLambda_subst. now eapply ELiftSubst.isLambda_subst. @@ -576,7 +576,7 @@ Lemma erases_subst0 (Σ : global_env_ext) Γ t s t' s' T : Proof. intros Hwf Hwfl Hty He Hall. change (@nil (BasicAst.context_decl term)) with (subst_context s 0 [] ++ nil). - eapply erases_subst with (Γ' := Γ); eauto. + eapply erases_subst with (Γ' := Γ); eauto. - cbn. unfold app_context. rewrite app_nil_r. eassumption. - cbn. unfold app_context. rewrite app_nil_r. eassumption. Qed. diff --git a/erasure/theories/ETransform.v b/erasure/theories/ETransform.v index f33007b2f..5422639d0 100644 --- a/erasure/theories/ETransform.v +++ b/erasure/theories/ETransform.v @@ -14,13 +14,13 @@ Import PCUICAst (term) PCUICProgram PCUICTransform (eval_pcuic_program) Extract EAst Transform ERemoveParams. Import EEnvMap EGlobalEnv EWellformed. -Definition build_wf_env_from_env {cf : checker_flags} (Σ : global_env_map) (wfΣ : ∥ PCUICTyping.wf Σ ∥) : wf_env := +Definition build_wf_env_from_env {cf : checker_flags} (Σ : global_env_map) (wfΣ : ∥ PCUICTyping.wf Σ ∥) : wf_env := {| wf_env_referenced := {| referenced_impl_env := Σ.(trans_env_env); referenced_impl_wf := wfΣ |} ; wf_env_map := Σ.(trans_env_map); wf_env_map_repr := Σ.(trans_env_repr); |}. -Program Definition erase_pcuic_program {guard : abstract_guard_impl} (p : pcuic_program) +Program Definition erase_pcuic_program {guard : abstract_guard_impl} (p : pcuic_program) (wfΣ : ∥ PCUICTyping.wf_ext (H := config.extraction_checker_flags) p.1 ∥) (wt : ∥ ∑ T, PCUICTyping.typing (H := config.extraction_checker_flags) p.1 [] p.2 T ∥) : eprogram_env := let wfe := build_wf_env_from_env p.1.1 (map_squash (PCUICTyping.wf_ext_wf _) wfΣ) in @@ -40,11 +40,11 @@ Obligation Tactic := idtac. Import Extract. -Definition erase_program {guard : abstract_guard_impl} (p : pcuic_program) +Definition erase_program {guard : abstract_guard_impl} (p : pcuic_program) (wtp : ∥ wt_pcuic_program (cf:=config.extraction_checker_flags) p ∥) : eprogram_env := erase_pcuic_program (guard := guard) p (map_squash fst wtp) (map_squash snd wtp). -Lemma expanded_erase_program {guard : abstract_guard_impl} +Lemma expanded_erase_program {guard : abstract_guard_impl} (cf := config.extraction_checker_flags) p (wtp : ∥ wt_pcuic_program p ∥) : PCUICEtaExpand.expanded_pcuic_program p -> EEtaExpandedFix.expanded_eprogram_env (erase_program (guard:=guard) p wtp). @@ -67,10 +67,10 @@ Proof. - eapply EEtaExpanded.isEtaExpFix_isEtaExp. now eapply EEtaExpandedFix.expanded_isEtaExp. Qed. -Program Definition erase_transform {guard : abstract_guard_impl} : Transform.t pcuic_program eprogram_env PCUICAst.term EAst.term +Program Definition erase_transform {guard : abstract_guard_impl} : Transform.t pcuic_program eprogram_env PCUICAst.term EAst.term eval_pcuic_program (eval_eprogram_env EWcbvEval.default_wcbv_flags) := {| name := "erasure"; - pre p := + pre p := ∥ wt_pcuic_program (cf := config.extraction_checker_flags) p ∥ /\ PCUICEtaExpand.expanded_pcuic_program p ; transform p hp := erase_program (guard:=guard) p (proj1 hp) ; post p := [/\ wf_eprogram_env all_env_flags p & EEtaExpandedFix.expanded_eprogram_env p]; @@ -81,7 +81,7 @@ Next Obligation. destruct erase_program eqn:e. split; cbn. - unfold erase_program, erase_pcuic_program in e. simpl. cbn in e. injection e. intros <- <-. - split. + split. eapply ErasureFunction.erase_global_fast_wf_glob. apply: (ErasureFunction.erase_wellformed_fast (X_type:=optimized_abstract_env_impl)). - rewrite -e. cbn. @@ -107,13 +107,13 @@ Next Obligation. Qed. (** This transformation is the identity on terms but changes the evaluation relation to one - where fixpoints are not guarded. It requires eta-expanded fixpoints and evaluation + where fixpoints are not guarded. It requires eta-expanded fixpoints and evaluation to use the guarded fixpoint rule as a precondition. *) Import EWcbvEval (WcbvFlags, with_prop_case, with_guarded_fix). Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} {efl : EEnvFlags} (wguard : with_guarded_fix) : - Transform.t eprogram_env eprogram_env EAst.term EAst.term + Transform.t eprogram_env eprogram_env EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram_env (EWcbvEval.switch_unguarded_fix fl)) := {| name := "switching to unguarded fixpoints"; transform p pre := p; @@ -134,7 +134,7 @@ Qed. Definition rebuild_wf_env {efl} (p : eprogram) (hwf : wf_eprogram efl p): eprogram_env := (GlobalContextMap.make p.1 (wf_glob_fresh p.1 (proj1 hwf)), p.2). -Program Definition rebuild_wf_env_transform {fl : EWcbvEval.WcbvFlags} {efl} (with_exp : bool) : +Program Definition rebuild_wf_env_transform {fl : EWcbvEval.WcbvFlags} {efl} (with_exp : bool) : Transform.t eprogram eprogram_env EAst.term EAst.term (eval_eprogram fl) (eval_eprogram_env fl) := {| name := "rebuilding environment lookup table"; pre p := wf_eprogram efl p /\ (with_exp ==> EEtaExpanded.expanded_eprogram_cstrs p); @@ -149,7 +149,7 @@ Next Obligation. Qed. Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} - (efl := all_env_flags): + (efl := all_env_flags): Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := {| name := "stripping constructor parameters"; transform p pre := ERemoveParams.strip_program p; @@ -187,7 +187,7 @@ Next Obligation. simpl. cbn -[ERemoveParams.strip] in *. rewrite -ERemoveParams.Fast.strip_fast -ERemoveParams.Fast.strip_env_fast. - split. + split. now eapply (ERemoveParams.strip_program_wf (Σ, t)). now eapply (ERemoveParams.strip_program_expanded (Σ, t)). Qed. @@ -207,9 +207,9 @@ Qed. Import EOptimizePropDiscr EWcbvEval. Program Definition optimize_prop_discr_optimization {fl : WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} : - Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram (disable_prop_cases fl)) := - {| name := "optimize_prop_discr"; - transform p _ := optimize_program p ; + Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram (disable_prop_cases fl)) := + {| name := "optimize_prop_discr"; + transform p _ := optimize_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; post p := wf_eprogram efl p /\ EEtaExpanded.expanded_eprogram_cstrs p; obseq g g' v v' := v' = EOptimizePropDiscr.optimize g.1 v |}. @@ -233,9 +233,9 @@ From MetaCoq.Erasure Require Import EInlineProjections. Program Definition inline_projections_optimization {fl : WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := switch_no_params all_env_flags) {hastrel : has_tRel} {hastbox : has_tBox} : - Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := - {| name := "primitive projection inlining"; - transform p _ := EInlineProjections.optimize_program p ; + Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := + {| name := "primitive projection inlining"; + transform p _ := EInlineProjections.optimize_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; post p := wf_eprogram (disable_projections_env_flag efl) p /\ EEtaExpanded.expanded_eprogram_cstrs p; obseq g g' v v' := v' = EInlineProjections.optimize g.1 v |}. @@ -257,15 +257,15 @@ From MetaCoq.Erasure Require Import EConstructorsAsBlocks. Program Definition constructors_as_blocks_transformation (efl : EEnvFlags) {has_app : has_tApp} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = false} : - Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env target_wcbv_flags) (eval_eprogram block_wcbv_flags) := - {| name := "transforming to constuctors as blocks"; - transform p _ := EConstructorsAsBlocks.transform_blocks_program p ; + Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env target_wcbv_flags) (eval_eprogram block_wcbv_flags) := + {| name := "transforming to constuctors as blocks"; + transform p _ := EConstructorsAsBlocks.transform_blocks_program p ; pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; post p := wf_eprogram (switch_cstr_as_blocks efl) p ; obseq g g' v v' := v' = EConstructorsAsBlocks.transform_blocks g.1 v |}. Next Obligation. - move=> efl hasapp haspars hascstrs [Σ t] [] [wftp wft] /andP [etap etat]. + move=> efl hasapp haspars hascstrs [Σ t] [] [wftp wft] /andP [etap etat]. cbn in *. split. - eapply transform_wf_global; eauto. - eapply transform_wellformed; eauto. @@ -274,8 +274,8 @@ Next Obligation. red. move=> efl hasapp haspars hascstrs [Σ t] /= v [[wfe1 wfe2] wft] [ev]. eexists. split; [ | eauto]. unfold EEtaExpanded.expanded_eprogram_env_cstrs in *. - revert wft. move => /andP // [e1 e2]. - econstructor. + revert wft. move => /andP // [e1 e2]. + econstructor. cbn -[transform_blocks]. eapply transform_blocks_eval; cbn; eauto. Qed. diff --git a/erasure/theories/EWcbvEval.v b/erasure/theories/EWcbvEval.v index abb7bb6bf..6f5589724 100644 --- a/erasure/theories/EWcbvEval.v +++ b/erasure/theories/EWcbvEval.v @@ -28,7 +28,7 @@ Local Ltac inv H := inversion H; subst. (** ** Big step version of weak cbv beta-zeta-iota-fix-delta reduction. *) -(* Tells if the evaluation relation should include match-prop and proj-prop reduction rules. +(* Tells if the evaluation relation should include match-prop and proj-prop reduction rules. Also, are constructors represented as blocks or higher-order. *) Class WcbvFlags := { with_prop_case : bool ; with_guarded_fix : bool ; with_constructor_as_block : bool }. @@ -62,7 +62,7 @@ Qed. Definition disable_prop_cases fl : WcbvFlags := {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) ; with_constructor_as_block := fl.(@with_constructor_as_block) |}. -Definition switch_unguarded_fix fl : WcbvFlags := +Definition switch_unguarded_fix fl : WcbvFlags := EWcbvEval.Build_WcbvFlags fl.(@with_prop_case) false fl.(@with_constructor_as_block). Definition default_wcbv_flags := {| with_prop_case := true ; with_guarded_fix := true ; with_constructor_as_block := false |}. @@ -107,7 +107,7 @@ Section Wcbv. Context {wfl : WcbvFlags}. Context (Σ : global_declarations). (* The local context is fixed: we are only doing weak reductions *) - + Local Unset Elimination Schemes. Inductive eval : term -> term -> Set := @@ -217,7 +217,7 @@ Section Wcbv. nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a -> eval a res -> eval (tProj p discr) res - + (** Proj *) | eval_proj_block p cdecl discr args a res : with_constructor_as_block = true -> @@ -236,10 +236,10 @@ Section Wcbv. eval (tProj p discr) tBox (** Constructor congruence: we do not allow over-applications *) - | eval_construct ind c mdecl idecl cdecl f args a a' : + | eval_construct ind c mdecl idecl cdecl f args a a' : with_constructor_as_block = false -> lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> - eval f (mkApps (tConstruct ind c []) args) -> + eval f (mkApps (tConstruct ind c []) args) -> #|args| < cstr_arity mdecl cdecl -> eval a a' -> eval (tApp f a) (tApp (mkApps (tConstruct ind c []) args) a') @@ -273,7 +273,7 @@ Section Wcbv. Hint Constructors eval : core. Derive Signature for eval. Derive NoConfusionHom for term. - + (** Characterization of values for this reduction relation. Only constructors and cofixpoints can accumulate arguments. All other values are atoms and cannot have arguments: @@ -290,20 +290,20 @@ Section Wcbv. nargs <= cstr_arity mdecl cdecl -> value_head nargs (tConstruct ind c []) | value_head_cofix mfix idx : value_head nargs (tCoFix mfix idx) - | value_head_fix mfix idx rarg fn : + | value_head_fix mfix idx rarg fn : cunfold_fix mfix idx = Some (rarg, fn) -> - (* If fixpoints are not guarded, we don't need to consider applied fixpoints + (* If fixpoints are not guarded, we don't need to consider applied fixpoints as value heads*) (if with_guarded_fix then nargs <= rarg else False) -> value_head nargs (tFix mfix idx). Derive Signature NoConfusion for value_head. - + Inductive value : term -> Type := | value_atom t : atom Σ t -> value t - | value_constructor ind c mdecl idecl cdecl args : - with_constructor_as_block = true -> + | value_constructor ind c mdecl idecl cdecl args : + with_constructor_as_block = true -> lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> - #|args| = cstr_arity mdecl cdecl -> + #|args| = cstr_arity mdecl cdecl -> All value args -> value (tConstruct ind c args) | value_app_nonnil f args : value_head #|args| f -> args <> [] -> All value args -> value (mkApps f args). Derive Signature for value. @@ -315,9 +315,9 @@ Proof. rename eval_depth into aux. destruct ev. all:try match goal with - | [ H : eval _ _ _, H' : eval _ _ _, H'' : eval _ _ _ |- _ ] => + | [ H : eval _ _ _, H' : eval _ _ _, H'' : eval _ _ _ |- _ ] => apply aux in H; apply aux in H'; apply aux in H''; exact (S (Nat.max H (Nat.max H' H''))) - | [ H : eval _ _ _, H' : eval _ _ _ |- _ ] => + | [ H : eval _ _ _, H' : eval _ _ _ |- _ ] => apply aux in H; apply aux in H'; exact (S (Nat.max H H')) | [ H : eval _ _ _ |- _ ] => apply aux in H; exact (S H) end. @@ -327,7 +327,7 @@ Defined. Set Equations Transparent. Section eval_rect. - + Variables (wfl : WcbvFlags) (Σ : global_declarations) (P : forall x y, eval Σ x y → Type). Equations All2_over {A B : Set} {P : A → B → Set} {l : list A} {l' : list B} : @@ -335,12 +335,12 @@ Section eval_rect. | All2_nil, _ := unit | All2_cons rxy rll', Q => Q _ _ rxy × All2_over rll' Q. - Lemma eval_rect : + Lemma eval_rect : (∀ (a t t' : term) (e : eval Σ a tBox), P a tBox e → ∀ e0 : eval Σ t t', P t t' e0 → P (tApp a t) tBox (eval_box Σ a t t' e e0)) - → (∀ (f0 : term) (na : name) (b a a' res : term) + → (∀ (f0 : term) (na : name) (b a a' res : term) (e : eval Σ f0 (tLambda na b)), P f0 (tLambda na b) e → ∀ e0 : eval Σ a a', @@ -353,89 +353,89 @@ Section eval_rect. → ∀ e0 : eval Σ (csubst b0' 0 b1) res, P (csubst b0' 0 b1) res e0 → P (tLetIn na b0 b1) res (eval_zeta Σ na b0 b0' b1 res e e0)) - → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) - (discr : term) (c : nat) (args : list term) - (brs : list (list name × term)) (br : list name × term) - (res : term) (e : with_constructor_as_block = false) + → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) + (discr : term) (c : nat) (args : list term) + (brs : list (list name × term)) (br : list name × term) + (res : term) (e : with_constructor_as_block = false) (e0 : eval Σ discr (mkApps (tConstruct ind c []) args)), P discr (mkApps (tConstruct ind c []) args) e0 → ∀ (e1 : constructor_isprop_pars_decl Σ ind c = - Some (false, pars, cdecl)) (e2 : - nth_error brs c = - Some br) - (e3 : #|args| = pars + cstr_nargs cdecl) - (e4 : #|skipn pars args| = #|br.1|) + Some (false, pars, cdecl)) (e2 : + nth_error brs c = + Some br) + (e3 : #|args| = pars + cstr_nargs cdecl) + (e4 : #|skipn pars args| = #|br.1|) (e5 : eval Σ (iota_red pars args br) res), P (iota_red pars args br) res e5 → P (tCase (ind, pars) discr brs) res (eval_iota Σ ind pars cdecl discr c args brs br res e e0 e1 e2 e3 e4 e5)) - → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) - (discr : term) (c : nat) (args : list term) - (brs : list (list name × term)) (br : list name × term) - (res : term) (e : with_constructor_as_block = true) + → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) + (discr : term) (c : nat) (args : list term) + (brs : list (list name × term)) (br : list name × term) + (res : term) (e : with_constructor_as_block = true) (e0 : eval Σ discr (tConstruct ind c args)), P discr (tConstruct ind c args) e0 → ∀ (e1 : constructor_isprop_pars_decl Σ ind c = - Some (false, pars, cdecl)) - (e2 : nth_error brs c = Some br) - (e3 : #|args| = pars + cstr_nargs cdecl) - (e4 : #|skipn pars args| = #|br.1|) + Some (false, pars, cdecl)) + (e2 : nth_error brs c = Some br) + (e3 : #|args| = pars + cstr_nargs cdecl) + (e4 : #|skipn pars args| = #|br.1|) (e5 : eval Σ (iota_red pars args br) res), P (iota_red pars args br) res e5 → P (tCase (ind, pars) discr brs) res (eval_iota_block Σ ind pars cdecl discr c args brs br res e e0 e1 e2 e3 e4 e5)) - → (∀ (ind : inductive) (pars : nat) (discr : term) - (brs : list (list name × term)) (n : list name) - (f4 res : term) (i : with_prop_case) + → (∀ (ind : inductive) (pars : nat) (discr : term) + (brs : list (list name × term)) (n : list name) + (f4 res : term) (i : with_prop_case) (e : eval Σ discr tBox), P discr tBox e - → ∀ (e0 : inductive_isprop_and_pars Σ ind = Some (true, pars)) + → ∀ (e0 : inductive_isprop_and_pars Σ ind = Some (true, pars)) (e1 : brs = [(n, f4)]) (e2 : eval Σ - (substl + (substl (repeat tBox #|n|) f4) res), P (substl (repeat tBox #|n|) f4) res e2 → P (tCase (ind, pars) discr brs) res (eval_iota_sing Σ ind pars discr brs n f4 res i e e0 e1 e2)) - → (∀ (f5 : term) (mfix : mfixpoint term) - (idx : nat) (argsv : list term) (a av fn res : term) - (guarded : with_guarded_fix) (e : + → (∀ (f5 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) (a av fn res : term) + (guarded : with_guarded_fix) (e : eval Σ f5 - (mkApps + (mkApps (tFix mfix idx) argsv)), P f5 (mkApps (tFix mfix idx) argsv) e → ∀ e0 : eval Σ a av, P a av e0 - → ∀ (e1 : cunfold_fix mfix idx = Some (#|argsv|, fn)) + → ∀ (e1 : cunfold_fix mfix idx = Some (#|argsv|, fn)) (e2 : eval Σ (tApp (mkApps fn argsv) av) res), P (tApp (mkApps fn argsv) av) res e2 → P (tApp f5 a) res (eval_fix Σ f5 mfix idx argsv a av fn res guarded e e0 e1 e2)) - → (∀ (f6 : term) (mfix : mfixpoint term) - (idx : nat) (argsv : list term) - (a av : term) (narg : nat) (fn : term) - (guarded : with_guarded_fix) (e : + → (∀ (f6 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) + (a av : term) (narg : nat) (fn : term) + (guarded : with_guarded_fix) (e : eval Σ f6 - (mkApps + (mkApps (tFix mfix idx) argsv)), P f6 (mkApps (tFix mfix idx) argsv) e → ∀ e0 : eval Σ a av, P a av e0 - → ∀ (e1 : cunfold_fix mfix idx = Some (narg, fn)) + → ∀ (e1 : cunfold_fix mfix idx = Some (narg, fn)) (l : #|argsv| < narg), P (tApp f6 a) (tApp (mkApps (tFix mfix idx) argsv) av) (eval_fix_value Σ f6 mfix idx argsv a av narg fn guarded e e0 e1 l)) - → (∀ (f7 : term) (mfix : mfixpoint term) - (idx : nat) (a av fn res : term) - (narg : nat) (unguarded : with_guarded_fix = false) + → (∀ (f7 : term) (mfix : mfixpoint term) + (idx : nat) (a av fn res : term) + (narg : nat) (unguarded : with_guarded_fix = false) (e : eval Σ f7 (tFix mfix idx)), P f7 (tFix mfix idx) e - → ∀ (e0 : cunfold_fix mfix idx = Some (narg, fn)) + → ∀ (e0 : cunfold_fix mfix idx = Some (narg, fn)) (e1 : eval Σ a av), P a av e1 → ∀ e2 : eval Σ (tApp fn av) res, @@ -443,44 +443,44 @@ Section eval_rect. → P (tApp f7 a) res (eval_fix' Σ f7 mfix idx a av fn res narg unguarded e e0 e1 e2)) - → (∀ (ip : inductive × nat) (mfix : mfixpoint term) - (idx : nat) (args : list term) - (discr : term) (narg : nat) - (fn : term) (brs : list (list name × term)) + → (∀ (ip : inductive × nat) (mfix : mfixpoint term) + (idx : nat) (args : list term) + (discr : term) (narg : nat) + (fn : term) (brs : list (list name × term)) (res : term) (e : eval Σ discr (mkApps (tCoFix mfix idx) args)), P discr (mkApps (tCoFix mfix idx) args) e - → ∀ (e0 : cunfold_cofix mfix idx = Some (narg, fn)) + → ∀ (e0 : cunfold_cofix mfix idx = Some (narg, fn)) (e1 : eval Σ (tCase ip (mkApps fn args) brs) res), P (tCase ip (mkApps fn args) brs) res e1 → P (tCase ip discr brs) res (eval_cofix_case Σ ip mfix idx args discr narg fn brs res e e0 e1)) - → (∀ (p : projection) (mfix : mfixpoint term) - (idx : nat) (args : list term) - (discr : term) (narg : nat) + → (∀ (p : projection) (mfix : mfixpoint term) + (idx : nat) (args : list term) + (discr : term) (narg : nat) (fn res : term) (e : eval Σ discr - (mkApps + (mkApps (tCoFix mfix idx) args)), P discr (mkApps (tCoFix mfix idx) args) e - → ∀ (e0 : cunfold_cofix mfix idx = Some (narg, fn)) + → ∀ (e0 : cunfold_cofix mfix idx = Some (narg, fn)) (e1 : eval Σ (tProj p (mkApps fn args)) res), P (tProj p (mkApps fn args)) res e1 → P (tProj p discr) res (eval_cofix_proj Σ p mfix idx args discr narg fn res e e0 e1)) - → (∀ (c : kername) (decl : constant_body) - (body : term) (isdecl : - declared_constant Σ c decl) - (res : term) (e : cst_body decl = Some body) + → (∀ (c : kername) (decl : constant_body) + (body : term) (isdecl : + declared_constant Σ c decl) + (res : term) (e : cst_body decl = Some body) (e0 : eval Σ body res), P body res e0 → P (tConst c) res (eval_delta Σ c decl body isdecl res e e0)) - → (∀ (p : projection) (cdecl : constructor_body) - (discr : term) (args : list term) + → (∀ (p : projection) (cdecl : constructor_body) + (discr : term) (args : list term) (a res : term) (e : with_constructor_as_block = - false) + false) (e0 : eval Σ discr (mkApps (tConstruct (proj_ind p) 0 []) args)), @@ -489,29 +489,29 @@ Section eval_rect. e0 → ∀ (e1 : constructor_isprop_pars_decl Σ (proj_ind p) 0 = - Some (false, proj_npars p, cdecl)) + Some (false, proj_npars p, cdecl)) (e2 : #|args| = - proj_npars p + cstr_nargs cdecl) + proj_npars p + cstr_nargs cdecl) (e3 : nth_error args - (proj_npars p + proj_arg p) = + (proj_npars p + proj_arg p) = Some a) (e4 : eval Σ a res), P a res e4 → P (tProj p discr) res (eval_proj Σ p cdecl discr args a res e e0 e1 e2 e3 e4)) - → (∀ (p : projection) (cdecl : constructor_body) - (discr : term) (args : list term) - (a res : term) (e : + → (∀ (p : projection) (cdecl : constructor_body) + (discr : term) (args : list term) + (a res : term) (e : with_constructor_as_block = - true) + true) (e0 : eval Σ discr (tConstruct (proj_ind p) 0 args)), P discr (tConstruct (proj_ind p) 0 args) e0 → ∀ (e1 : constructor_isprop_pars_decl Σ (proj_ind p) 0 = - Some (false, proj_npars p, cdecl)) + Some (false, proj_npars p, cdecl)) (e2 : #|args| = - proj_npars p + cstr_nargs cdecl) + proj_npars p + cstr_nargs cdecl) (e3 : nth_error args (proj_npars p + proj_arg p) = Some a) (e4 : eval Σ a res), @@ -519,8 +519,8 @@ Section eval_rect. → P (tProj p discr) res (eval_proj_block Σ p cdecl discr args a res e e0 e1 e2 e3 e4)) - → (∀ (p : projection) - (discr : term) (i : with_prop_case) + → (∀ (p : projection) + (discr : term) (i : with_prop_case) (e : eval Σ discr tBox), P discr tBox e → ∀ e0 : inductive_isprop_and_pars Σ @@ -528,64 +528,64 @@ Section eval_rect. Some (true, proj_npars p), P (tProj p discr) tBox (eval_proj_prop Σ p discr i e e0)) - → (∀ (ind : inductive) - (c : nat) (mdecl : mutual_inductive_body) - (idecl : one_inductive_body) - (cdecl : constructor_body) - (f14 : term) (args : list term) - (a a' : term) (e : + → (∀ (ind : inductive) + (c : nat) (mdecl : mutual_inductive_body) + (idecl : one_inductive_body) + (cdecl : constructor_body) + (f14 : term) (args : list term) + (a a' : term) (e : with_constructor_as_block = - false) + false) (e0 : lookup_constructor Σ ind c = - Some (mdecl, idecl, cdecl)) + Some (mdecl, idecl, cdecl)) (e1 : eval Σ f14 (mkApps (tConstruct ind c []) args)), P f14 (mkApps (tConstruct ind c []) args) e1 - → ∀ (l : #|args| < cstr_arity mdecl cdecl) + → ∀ (l : #|args| < cstr_arity mdecl cdecl) (e2 : eval Σ a a'), P a a' e2 → P (tApp f14 a) (tApp - (mkApps + (mkApps (tConstruct ind c []) args) a') (eval_construct Σ ind c mdecl idecl cdecl f14 args a a' e e0 e1 l e2)) - → (∀ (ind : inductive) - (c : nat) (mdecl : mutual_inductive_body) - (idecl : one_inductive_body) - (cdecl : constructor_body) - (args args' : - list term) (e : + → (∀ (ind : inductive) + (c : nat) (mdecl : mutual_inductive_body) + (idecl : one_inductive_body) + (cdecl : constructor_body) + (args args' : + list term) (e : with_constructor_as_block = - true) + true) (e0 : lookup_constructor Σ ind c = - Some (mdecl, idecl, cdecl)) - (e1 : #|args| = cstr_arity mdecl cdecl) + Some (mdecl, idecl, cdecl)) + (e1 : #|args| = cstr_arity mdecl cdecl) (a : All2_Set (eval Σ) args args') (iha : All2_over a P), P (tConstruct ind c args) (tConstruct ind c args') (eval_construct_block Σ ind c mdecl idecl cdecl args args' e e0 e1 a)) - → (∀ (f16 f' a a' : term) + → (∀ (f16 f' a a' : term) (e : eval Σ f16 f'), P f16 f' e → ∀ (i : ~~ (isLambda f' - || + || (if with_guarded_fix then isFixApp f' - else isFix f') || + else isFix f') || isBox f' - || + || isConstructApp f' - || isPrimApp f')) + || isPrimApp f')) (e0 : eval Σ a a'), P a a' e0 - → P (tApp f16 a) + → P (tApp f16 a) (tApp f' a') (eval_app_cong Σ f16 f' a a' e i e0)) @@ -599,7 +599,7 @@ Section eval_rect. fix aux 3. move aux at top. intros t t0 H. - destruct H. + destruct H. all:try match goal with | [ H : _ |- _ ] => eapply H; (unshelve eapply aux || tea); tea; cbn; try lia @@ -611,7 +611,7 @@ Section eval_rect. Definition eval_rec := eval_rect. Definition eval_ind := eval_rect. -End eval_rect. +End eval_rect. Global Hint Constructors value : value. @@ -631,8 +631,8 @@ Section Wcbv. Lemma value_values_ind : forall P : term -> Type, (forall t, atom Σ t -> P t) -> - (forall (ind : inductive) (c : nat) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body) - (args : list term) (e : with_constructor_as_block = true) (e0 : lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl)) + (forall (ind : inductive) (c : nat) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body) + (args : list term) (e : with_constructor_as_block = true) (e0 : lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl)) (l : #|args| = cstr_arity mdecl cdecl) (a : All value args) , All P args -> P (tConstruct ind c args)) -> (forall f args, value_head #|args| f -> args <> [] -> All value args -> All P args -> P (mkApps f args)) -> @@ -662,7 +662,7 @@ Section Wcbv. Lemma value_mkApps_inv t l : ~~ isApp t -> value (mkApps t l) -> - ((l = []) /\ atom Σ t) + ((l = []) /\ atom Σ t) + (l = [] × ∑ ind c mdecl idecl cdecl args, [ × with_constructor_as_block , lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl), t = tConstruct ind c args, #|args| = cstr_arity mdecl cdecl & All value args]) + ([× l <> [], value_head #|l| t & All value l]). Proof. @@ -672,14 +672,14 @@ Section Wcbv. now eapply atom_mkApps in H. - intros * wcon lup len H IH t ht hcon. destruct l using rev_ind. - + cbn in hcon. invs hcon. left. right. + + cbn in hcon. invs hcon. left. right. repeat eexists; eauto. + rewrite mkApps_app in hcon. invs hcon. - - intros * vh nargs hargs ih t isapp appeq. + - intros * vh nargs hargs ih t isapp appeq. move: (value_head_nApp vh) => Ht. right. apply mkApps_eq_inj in appeq => //. intuition subst; auto => //. Qed. - + Lemma value_mkApps_values t l : value (mkApps t l) -> ~~ isApp t -> @@ -688,7 +688,7 @@ Section Wcbv. intros val not_app. now apply value_mkApps_inv in val as [[(-> & ?) | [-> ] ] |[]]. Qed. - + Lemma eval_Construct_inv ind c args e : eval (tConstruct ind c args) e -> ∑ args', e = tConstruct ind c args' × All2 eval args args'. @@ -696,7 +696,7 @@ Section Wcbv. intros H. depind H. - repeat eexists; eauto. - invs i. destruct args; invs H0. exists []. repeat econstructor. - Qed. + Qed. Lemma eval_to_value e e' : eval e e' -> value e'. Proof. @@ -704,7 +704,7 @@ Section Wcbv. - change (tApp ?h ?a) with (mkApps h [a]). rewrite -mkApps_app. - apply value_mkApps_inv in IHev1; [|easy]. + apply value_mkApps_inv in IHev1; [|easy]. destruct IHev1 as [[(-> & _) | [-> ] ] |[]]. + apply value_app; auto. len. cbn in *. econstructor; tea. @@ -716,25 +716,25 @@ Section Wcbv. eapply value_app; auto. econstructor; tea. destruct with_guarded_fix => //. len; lia. apply All_app_inv; auto. - - - apply value_mkApps_inv in IHev1; [|easy]. + + - apply value_mkApps_inv in IHev1; [|easy]. destruct IHev1 as [[(-> & _)|[-> ]] | []]. + cbn. eapply (value_app _ [a']); cbn; auto. econstructor; tea. + cbn. eapply (value_app _ [a']); cbn; auto. econstructor; tea. + rewrite -[tApp _ _](mkApps_app _ _ [a']). eapply value_app. cbn; auto. econstructor; tea. cbn; len. eapply All_app_inv; auto. - + - econstructor 2; tea. now rewrite -(All2_length a). clear -a iha. induction a. constructor. destruct iha as [va' ih]. constructor. exact va'. now apply IHa. - + - destruct (mkApps_elim f' [a']). eapply value_mkApps_inv in IHev1 => //. destruct IHev1 as [?|[]]; intuition subst. * rewrite H in i |- *. simpl in *. - apply (value_app f [a']). + apply (value_app f [a']). destruct f; simpl in * |- *; try congruence. + rewrite !negb_or /= in i; rtoProp; intuition auto. + rewrite !negb_or /= in i; rtoProp; intuition auto. @@ -746,7 +746,7 @@ Section Wcbv. * destruct b0 as (ind & c & mdecl & idecl & cdecl & args & [H1 H2 H3 H4]). rewrite -[tApp _ _](mkApps_app _ (firstn n l) [a']). rewrite a0 in i |- *. simpl in *. - apply (value_app f [a']). + apply (value_app f [a']). destruct f; simpl in * |- *; try congruence. + rewrite !negb_or /= in i; rtoProp; intuition auto. + destruct with_guarded_fix. now cbn in i. now cbn in i. @@ -773,7 +773,7 @@ Section Wcbv. destruct 1. - constructor; try easy. now cbn [atom]; rewrite e e0. - now eapply eval_atom. - - now eapply eval_atom. + - now eapply eval_atom. Qed. (** The codomain of evaluation is only values: *) @@ -786,11 +786,11 @@ Section Wcbv. Qed. - Lemma closed_fix_substl_subst_eq {mfix idx d} : + Lemma closed_fix_substl_subst_eq {mfix idx d} : closed (tFix mfix idx) -> nth_error mfix idx = Some d -> subst0 (fix_subst mfix) (dbody d) = substl (fix_subst mfix) (dbody d). - Proof. + Proof. move=> /= Hf; f_equal; f_equal. have clfix : All (closedn 0) (fix_subst mfix). { clear idx. @@ -811,7 +811,7 @@ Section Wcbv. f_equal. rewrite lift_closed // closed_subst //. Qed. - Lemma closed_unfold_fix_cunfold_eq mfix idx : + Lemma closed_unfold_fix_cunfold_eq mfix idx : closed (tFix mfix idx) -> unfold_fix mfix idx = cunfold_fix mfix idx. Proof. @@ -821,11 +821,11 @@ Section Wcbv. now rewrite (closed_fix_substl_subst_eq cl). Qed. - Lemma closed_cofix_substl_subst_eq {mfix idx d} : + Lemma closed_cofix_substl_subst_eq {mfix idx d} : closed (tCoFix mfix idx) -> nth_error mfix idx = Some d -> subst0 (cofix_subst mfix) (dbody d) = substl (cofix_subst mfix) (dbody d). - Proof. + Proof. move=> /= Hf; f_equal; f_equal. have clfix : All (closedn 0) (cofix_subst mfix). { clear idx. @@ -846,10 +846,10 @@ Section Wcbv. f_equal. rewrite lift_closed // closed_subst //. Qed. - Lemma closed_unfold_cofix_cunfold_eq mfix idx : + Lemma closed_unfold_cofix_cunfold_eq mfix idx : closed (tCoFix mfix idx) -> unfold_cofix mfix idx = cunfold_cofix mfix idx. - Proof. + Proof. unfold unfold_cofix, cunfold_cofix. destruct (nth_error mfix idx) eqn:Heq => //. intros cl; f_equal; f_equal. @@ -873,7 +873,7 @@ Section Wcbv. now rewrite mkApps_app. * easy. Qed. - + Lemma eval_mkApps_tFix_inv mfix idx args v : with_guarded_fix -> eval (mkApps (tFix mfix idx) args) v -> @@ -890,7 +890,7 @@ Section Wcbv. all: try (eapply IHargs in ev1 as [(? & ? & Heq) | (? & ? & ? & ?)]; eauto; rewrite ?Heq; try solve_discr; len; rewrite ?Heq; rewrite Nat.add_comm; eauto 7). * invs H. eauto 9. - * invs H. left. exists (x0 ++ [av]). rewrite mkApps_app. cbn. split. eauto. len. + * invs H. left. exists (x0 ++ [av]). rewrite mkApps_app. cbn. split. eauto. len. * subst. rewrite isFixApp_mkApps in i => //. rewrite v in i. cbn in i. destruct isLambda; cbn in i; easy. * invs i. @@ -930,13 +930,13 @@ Section Wcbv. rewrite !mkApps_app /=. destruct cunfold_fix as [[rarg fn]|] eqn:eqc => //. len; cbn. move/Nat.leb_le => hrarg. - eapply eval_fix_value. auto. + eapply eval_fix_value. auto. eapply IHargs => //. unfold isStuckFix. rewrite eqc. apply Nat.leb_le; lia. auto. tea. rewrite -(All2_length evl). lia. Qed. Lemma stuck_fix_value_inv argsv mfix idx narg fn : - value (mkApps (tFix mfix idx) argsv) -> + value (mkApps (tFix mfix idx) argsv) -> cunfold_fix mfix idx = Some (narg, fn) -> (All value argsv × isStuckFix (tFix mfix idx) argsv). Proof. @@ -953,7 +953,7 @@ Section Wcbv. intros [= <- <-]. destruct with_guarded_fix => //. split => //. unfold isStuckFix. rewrite e. now apply Nat.leb_le. Qed. - + Lemma stuck_fix_value_args argsv mfix idx narg fn : value (mkApps (tFix mfix idx) argsv) -> cunfold_fix mfix idx = Some (narg, fn) -> @@ -1008,7 +1008,7 @@ Section Wcbv. - eapply All2_app_inv_l in evargs as [r1 [r2 [-> [evl evr]]]]. depelim evr. depelim evr. rewrite !mkApps_app /=. - eapply eval_app_cong; tea. + eapply eval_app_cong; tea. eapply IHargs => //. rewrite isFixApp_mkApps // /= isConstructApp_mkApps // !negb_or isPrimApp_mkApps. rtoProp; intuition auto. @@ -1059,9 +1059,9 @@ Section Wcbv. econstructor; tea; auto. - assert (All2 eval args args). { clear -X0; induction X0; constructor; auto. } - eapply eval_mkApps_cong => //. now eapply value_head_final. + eapply eval_mkApps_cong => //. now eapply value_head_final. Qed. - + Set Equations With UIP. Unset SsrRewrite. @@ -1083,7 +1083,7 @@ Section Wcbv. depind ev; intros v' ev'. - depelim ev'; try go. specialize (IHev1 _ ev'1). noconf IHev1. - specialize (IHev2 _ ev'2). noconf IHev2. cbn in i. + specialize (IHev2 _ ev'2). noconf IHev2. cbn in i. exfalso. destruct (@with_guarded_fix wfl); easy. - depelim ev'; go. - depelim ev'; go. @@ -1124,7 +1124,7 @@ Section Wcbv. assert (fn0 = fn) as -> by congruence. assert (e1 = e) as -> by now apply uip. rewrite (uip guarded guarded0). - now specialize (IHev3 _ ev'3); noconf IHev3. + now specialize (IHev3 _ ev'3); noconf IHev3. + specialize (IHev1 _ ev'1). pose proof (mkApps_eq_inj (f_equal pr1 IHev1) eq_refl eq_refl) as (? & <-). noconf H. @@ -1287,7 +1287,7 @@ Section Wcbv. pose proof (eval_unique_sig ev ev'). now noconf H. Qed. - + Lemma eval_deterministic_all {t v v'} : All2 eval t v -> All2 eval t v' -> @@ -1305,7 +1305,7 @@ Section Wcbv. eapply value_final in ev. eapply (eval_deterministic ev ev'). Qed. - + Lemma eval_trans {e e' e''} : eval e e' -> eval e' e'' -> eval e e''. Proof. @@ -1378,11 +1378,11 @@ Proof. + specialize (IHargs _ _ ev1) as [f' [evf' [args' [Hargs' evars]]]]. exists f'. split => //. eexists. split. eapply All2_app; eauto. - rewrite mkApps_app. + rewrite mkApps_app. eapply eval_beta; tea. eapply value_final; eapply eval_to_value; eauto. + specialize (IHargs _ _ ev1) as [f' [evf' ev]]. - exists f'; split => //. (* + exists f'; split => //. (* rewrite mkApps_app. eapply eval_fix; tea. *) + specialize (IHargs _ _ ev1) as [f' [evf' ev]]. @@ -1392,8 +1392,8 @@ Proof. + specialize (IHargs _ _ ev1) as [f' [evf' [args' [Hargs' evars]]]]. exists f'. split => //. eexists. split. eapply All2_app; eauto.> - rewrite mkApps_app. - + rewrite mkApps_app. + specialize (IHargs _ _ ev1) as [f' [evf' ev]]. exists f'; split => //. rewrite mkApps_app. @@ -1412,12 +1412,12 @@ Arguments eval_unique {_ _ _ _}. Section WcbvEnv. Context {wfl : WcbvFlags} {efl : EEnvFlags}. - Lemma weakening_eval_env {Σ Σ'} : + Lemma weakening_eval_env {Σ Σ'} : wf_glob Σ' -> extends Σ Σ' -> forall v t, eval Σ v t -> eval Σ' v t. Proof. intros wf ex t v ev. - induction ev; try solve [econstructor; + induction ev; try solve [econstructor; eauto using (extends_lookup_constructor wf ex), (extends_constructor_isprop_pars_decl wf ex), (extends_is_propositional wf ex)]. econstructor; eauto. red in isdecl |- *. eauto using extends_lookup. econstructor; tea. @@ -1451,10 +1451,10 @@ Qed. Lemma closedn_mkApps k f args : closedn k (mkApps f args) = closedn k f && forallb (closedn k) args. Proof. induction args in f |- *; simpl; auto. - ring. rewrite IHargs /=. ring. + ring. rewrite IHargs /=. ring. Qed. -Lemma closed_fix_subst mfix : +Lemma closed_fix_subst mfix : forallb (EAst.test_def (closedn (#|mfix| + 0))) mfix -> forallb (closedn 0) (fix_subst mfix). Proof. @@ -1465,7 +1465,7 @@ Proof. cbn. rewrite H IHn //. Qed. -Lemma closed_cofix_subst mfix : +Lemma closed_cofix_subst mfix : forallb (EAst.test_def (closedn (#|mfix| + 0))) mfix -> forallb (closedn 0) (cofix_subst mfix). Proof. @@ -1476,7 +1476,7 @@ Proof. cbn. rewrite H IHn //. Qed. -Lemma closed_cunfold_fix mfix idx n f : +Lemma closed_cunfold_fix mfix idx n f : closed (EAst.tFix mfix idx) -> cunfold_fix mfix idx = Some (n, f) -> closed f. @@ -1485,14 +1485,14 @@ Proof. rewrite /cunfold_fix. destruct nth_error eqn:heq => //. cbn in cl. - have := (nth_error_forallb heq cl) => cld. + have := (nth_error_forallb heq cl) => cld. move=> [=] _ <-. eapply closed_substl. now eapply closed_fix_subst. rewrite fix_subst_length. apply cld. Qed. -Lemma closed_cunfold_cofix mfix idx n f : +Lemma closed_cunfold_cofix mfix idx n f : closed (EAst.tCoFix mfix idx) -> cunfold_cofix mfix idx = Some (n, f) -> closed f. @@ -1501,7 +1501,7 @@ Proof. rewrite /cunfold_cofix. destruct nth_error eqn:heq => //. cbn in cl. - have := (nth_error_forallb heq cl) => cld. + have := (nth_error_forallb heq cl) => cld. move=> [=] _ <-. eapply closed_substl. now eapply closed_cofix_subst. rewrite cofix_subst_length. @@ -1522,13 +1522,13 @@ Lemma All2_over_impl {A : Set} (P : A -> A -> Set) l l' (a : All2_Set P l l') {Q (forall x y, Q x y -> R x -> R y) -> All R l'. Proof. intros qr. - induction a; constructor. + induction a; constructor. - eapply qr. eapply ha. now depelim arl. - depelim arl. eapply IHa. apply ha. apply arl. Qed. (** Evaluation preserves closedness: *) -Lemma eval_closed {wfl : WcbvFlags} Σ : +Lemma eval_closed {wfl : WcbvFlags} Σ : closed_env Σ -> forall t u, closed t -> eval Σ t u -> closed u. Proof. @@ -1569,10 +1569,10 @@ Proof. - eapply IHev3. rtoProp. split; eauto. eapply closed_cunfold_fix; tea. eauto. - eapply IHev2. rewrite closedn_mkApps. - rewrite closedn_mkApps in IHev1. + rewrite closedn_mkApps in IHev1. specialize (IHev1 Hc). move/andP: IHev1 => [Hfix Hargs]. repeat (apply/andP; split; auto). - eapply closed_cunfold_cofix; tea. + eapply closed_cunfold_cofix; tea. - specialize (IHev1 Hc). eapply IHev2. rewrite closedn_mkApps in IHev1 *. move/andP: IHev1 => [Hfix Hargs]. rewrite closedn_mkApps Hargs. @@ -1599,16 +1599,16 @@ Qed. Ltac forward_keep H := match type of H with ?X -> _ => - let H' := fresh in + let H' := fresh in assert (H' : X) ; [|specialize (H H')] end. -Definition mk_env_flags has_ax has_pars tfl has_blocks := +Definition mk_env_flags has_ax has_pars tfl has_blocks := {| has_axioms := has_ax; has_cstr_params := has_pars; term_switches := tfl ; cstr_as_blocks := has_blocks |}. - + Global Hint Rewrite andb_true_r andb_false_r : simplifications. Global Hint Rewrite orb_false_r orb_true_r : simplifications. @@ -1616,7 +1616,7 @@ Tactic Notation "sim" "in" hyp(H) := repeat (cbn in H; autorewrite with simplifications in H). Ltac sim := repeat (cbn ; autorewrite with simplifications). -Lemma eval_wellformed {efl : EEnvFlags} {wfl : WcbvFlags} Σ : +Lemma eval_wellformed {efl : EEnvFlags} {wfl : WcbvFlags} Σ : forall (has_app : has_tApp), (* necessary due to mkApps *) wf_glob Σ -> forall t u, wellformed Σ 0 t -> eval Σ t u -> wellformed Σ 0 u. @@ -1631,7 +1631,7 @@ Proof. - eapply IHev2; eauto. eapply wellformed_iota_red_brs; tea => //. destruct cstr_as_blocks; solve_all. - destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. + destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. destruct args; cbn in H3; eauto; econstructor. - subst brs. eapply IHev2. sim in H0. eapply wellformed_substl => //. @@ -1645,10 +1645,10 @@ Proof. - eapply IHev3 => //. rtoProp; intuition auto. eapply wellformed_cunfold_fix => //; tea. cbn. rewrite H H1 H2 //. - eapply IHev2. rewrite wellformed_mkApps //. - rewrite wellformed_mkApps // in H2. + rewrite wellformed_mkApps // in H2. move/andP: H2 => [Hfix Hargs]. repeat (apply/andP; split; auto). - eapply wellformed_cunfold_cofix => //; tea. + eapply wellformed_cunfold_cofix => //; tea. - eapply IHev2. rewrite wellformed_mkApps // in H *. move/andP: H => [Hfix Hargs]. rewrite wellformed_mkApps // Hargs andb_true_r Hc Hc' /=. @@ -1663,7 +1663,7 @@ Proof. - eapply IHev2. eapply nth_error_forallb in e3; eauto. destruct cstr_as_blocks; eauto. - destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. + destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. destruct args; cbn in H0; eauto. - destruct cstr_as_blocks; try congruence. destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. @@ -1675,20 +1675,20 @@ Proof. depelim a => //. Qed. -Lemma remove_last_length {X} {l : list X} : +Lemma remove_last_length {X} {l : list X} : #|remove_last l| = match l with nil => 0 | _ => #|l| - 1 end. Proof. unfold remove_last. rewrite firstn_length. destruct l; cbn; lia. Qed. -Lemma remove_last_length' {X} {l : list X} : - l <> nil -> +Lemma remove_last_length' {X} {l : list X} : + l <> nil -> #|remove_last l| = #|l| - 1. Proof. intros. rewrite remove_last_length. destruct l; try congruence; lia. Qed. - + Local Hint Rewrite @remove_last_length : len. Lemma eval_mkApps_tFix_inv_size {wfl : WcbvFlags} Σ mfix idx args v : @@ -1704,9 +1704,9 @@ Proof. + rewrite mkApps_app in ev |- *. cbn in *. depelim ev. - - all: try(specialize (IHargs) with (Heval := ev1); - destruct IHargs as [(args' & ? & Heq) | (? & ? & ? & ? & ?)];eauto; + + all: try(specialize (IHargs) with (Heval := ev1); + destruct IHargs as [(args' & ? & Heq) | (? & ? & ? & ? & ?)];eauto; rewrite ?Heq; try solve_discr; try congruence; try noconf H; len; rewrite ?Heq; rewrite Nat.add_comm; eauto 9). * right. repeat eexists. destruct args; cbn; congruence. eauto. @@ -1757,7 +1757,7 @@ Lemma eval_mkApps_tFix_inv_size_unguarded {wfl : WcbvFlags} Σ mfix idx args v : with_guarded_fix = false -> forall Heval : eval Σ (mkApps (tFix mfix idx) args) v, (args = [] /\ v = tFix mfix idx) - + ∑ a av args' argsv, + + ∑ a av args' argsv, (args = a :: args')%list × All2 (fun a a' => (a = a') + (∑ H : eval Σ a a', eval_depth H < eval_depth Heval)) args' argsv × ∑ n fn, cunfold_fix mfix idx = Some (n, fn) × @@ -1770,7 +1770,7 @@ Proof. + rewrite mkApps_app in ev |- *. cbn in *. depelim ev; right. - + all: try(specialize (IHargs) with (Heval := ev1); destruct IHargs as [[-> Heq] | (a & aval & args' & argsv_ & Heqargs & Hall & n & fn_ & Hunf & Heva & Hevasz & Hev' & Hevsz')];eauto; try rewrite ?Heq; try solve_discr; try congruence; len; try rewrite ?Heq; rewrite ?Nat.add_comm; eauto 9). * subst. cbn. exists a, aval, (args' ++ [x])%list,(argsv_ ++ [t'])%list. split. reflexivity. @@ -1791,7 +1791,7 @@ Proof. cbn. generalize (mkApps_app (tApp fn_ aval) argsv_ [a']). generalize (EAst.mkApps (tApp fn_ aval) (argsv_ ++ [a'])). intros. subst. cbn. destruct size_final. cbn in *. lia. - + * invs Heq. exists x, av, [], []. repeat split. econstructor. repeat unshelve eexists; eauto. all:cbn; lia. * subst. cbn. eexists _, _, _, (argsv_ ++ [_])%list. repeat eexists. 2: eauto. @@ -1857,7 +1857,7 @@ Proof. + destruct (IHargs _ _ ev1) as [f' [args' [evf' [evars res]]]]. exists f', (args' ++ [av]); split => //. split => //. eapply All2_app; auto. - rewrite mkApps_app. + rewrite mkApps_app. eapply eval_fix'; eauto. eapply value_final, eval_to_value; tea. + specialize (IHargs _ _ ev1) as [f'' [args' [evf' [evars res]]]]. exists f'', (args' ++ [a']); split => //. split => //. @@ -1872,9 +1872,9 @@ Proof. + cbn in i. discriminate. Qed. -Lemma eval_mkApps_Construct_inv {fl : WcbvFlags} Σ kn c args e : - with_constructor_as_block = false -> - eval Σ (mkApps (tConstruct kn c []) args) e -> +Lemma eval_mkApps_Construct_inv {fl : WcbvFlags} Σ kn c args e : + with_constructor_as_block = false -> + eval Σ (mkApps (tConstruct kn c []) args) e -> ∑ args', [× isSome (lookup_constructor Σ kn c), (e = mkApps (tConstruct kn c []) args') & All2 (eval Σ) args args']. Proof. intros hblock. @@ -1887,21 +1887,21 @@ Proof. all:try specialize (IHargs _ ev1) as [? []]; try solve_discr; try noconf H. * exists (x0 ++ [a']). split => //. rewrite mkApps_app /= //. eapply All2_app; eauto. - * subst f'. + * subst f'. exists (x0 ++ [a'])%list. rewrite mkApps_app /= //. cbn in i. split => //. eapply All2_app; eauto. * now cbn in i. Qed. -Lemma eval_mkApps_Construct_block_inv {fl : WcbvFlags} Σ kn c args oargs e : - with_constructor_as_block -> - eval Σ (mkApps (tConstruct kn c args) oargs) e -> +Lemma eval_mkApps_Construct_block_inv {fl : WcbvFlags} Σ kn c args oargs e : + with_constructor_as_block -> + eval Σ (mkApps (tConstruct kn c args) oargs) e -> ∑ args', oargs = [] × (e = tConstruct kn c args') × All2 (eval Σ) args args'. Proof. intros hblock. revert e; induction oargs using rev_ind; intros e. - - intros ev. depelim ev. + - intros ev. depelim ev. + eexists. split. reflexivity. split. reflexivity. auto. + invs i. destruct args; invs H0. exists []. repeat econstructor. - intros ev. rewrite mkApps_app /= in ev. @@ -1909,7 +1909,7 @@ Proof. all: try specialize (IHoargs _ ev1) as (? & ? & E & ?); try congruence; try solve_discr; try noconf E. * subst. cbn in i. destruct with_guarded_fix; cbn in *; eauto. * invs i. -Qed. +Qed. Lemma eval_mkApps_inv_size {wfl : WcbvFlags} {Σ f args v} : forall ev : eval Σ (mkApps f args) v, @@ -1925,7 +1925,7 @@ Proof. depelim ev. + specialize (IHargs _ _ ev1) as [f' [args' [evf' [evfs evars [evres res]]]]]. exists f', (args' ++ [t']). exists evf'. - rewrite mkApps_app. + rewrite mkApps_app. split => //. cbn. lia. { eapply All2_app; auto. { cbn. solve_all. destruct H as [eva evas]; exists eva. lia. } @@ -1935,19 +1935,19 @@ Proof. exact (size_final _ _ _ ev2).π1. cbn. destruct size_final; cbn. lia. + specialize (IHargs _ _ ev1) as [f' [args' [evf' [evfs evars [evres res]]]]]. - exists f', (args' ++ [a']). exists evf'. split => //. + exists f', (args' ++ [a']). exists evf'. split => //. cbn; lia. { eapply All2_app; auto. { cbn. solve_all. destruct H as [eva evas]; exists eva. lia. } constructor; auto. exists ev2. cbn; lia. } rewrite mkApps_app. unshelve eexists. - eapply eval_beta; tea. + eapply eval_beta; tea. exact (size_final _ _ _ ev2).π1. cbn. destruct size_final; cbn; lia. + specialize (IHargs _ _ ev1) as [f' [args' [evf' [evfs evars [evres res]]]]]. - exists f', (args' ++ [av]); exists evf'; split => //. - cbn; lia. + exists f', (args' ++ [av]); exists evf'; split => //. + cbn; lia. { eapply All2_app; auto. { cbn. solve_all. destruct H as [eva evas]; exists eva. lia. } constructor; auto. exists ev2. cbn; lia. } @@ -1957,7 +1957,7 @@ Proof. destruct size_final; cbn; lia. + specialize (IHargs _ _ ev1) as [f' [args' [evf' [evfs evars [evres res]]]]]. exists f', (args' ++ [av]); exists evf'; split => //. - cbn; lia. + cbn; lia. { eapply All2_app; auto. { cbn. solve_all. destruct H as [eva evas]; exists eva. lia. } constructor; auto. exists ev2. cbn; lia. } @@ -1967,7 +1967,7 @@ Proof. destruct size_final; cbn; lia. + destruct (IHargs _ _ ev1) as [f' [args' [evf' [evfs evars [evres res]]]]]. exists f', (args' ++ [av]); exists evf'; split => //. - cbn; lia. + cbn; lia. { eapply All2_app; auto. { cbn. solve_all. destruct H as [eva evas]; exists eva. lia. } constructor; auto. exists ev2. cbn; lia. } @@ -1984,7 +1984,7 @@ Proof. rewrite mkApps_app. unshelve eexists. eapply eval_construct; tea. exact (size_final _ _ _ ev2).π1. cbn. - destruct size_final; cbn; lia. + destruct size_final; cbn; lia. + specialize (IHargs _ _ ev1) as [f'' [args' [evf' [evfs evars [evres res]]]]]. exists f'', (args' ++ [a']); exists evf'; split => //. cbn; lia. @@ -1994,7 +1994,7 @@ Proof. rewrite mkApps_app. unshelve eexists. eapply eval_app_cong; tea. exact (size_final _ _ _ ev2).π1. cbn. - destruct size_final; cbn; lia. + destruct size_final; cbn; lia. + cbn in i. discriminate. Qed. @@ -2017,10 +2017,10 @@ Proof. eapply (eval_mkApps_Construct_inv _ _ _ [] _ hblock) in x as [? []]; auto. subst f''. depelim a1. f_equal. eapply eval_deterministic_all; tea. - eapply All2_impl; tea; cbn; eauto. now intros x y []. + eapply All2_impl; tea; cbn; eauto. now intros x y []. Qed. -Lemma eval_construct_size {fl : WcbvFlags} [Σ kn c args e] : +Lemma eval_construct_size {fl : WcbvFlags} [Σ kn c args e] : with_constructor_as_block = false -> forall (ev : eval Σ (mkApps (tConstruct kn c []) args) e), ∑ args', (e = mkApps (tConstruct kn c []) args') × @@ -2035,7 +2035,7 @@ Lemma eval_box_apps {wfl : WcbvFlags}: All2 (eval Σ') x x' -> eval Σ' e tBox -> eval Σ' (mkApps e x) tBox. Proof. - intros Σ' e x H2. + intros Σ' e x H2. revert e H2; induction x using rev_ind; cbn; intros; eauto. eapply All2_app_inv_l in X as (l1' & l2' & -> & H' & H2). depelim H2. diff --git a/erasure/theories/EWcbvEvalCstrsAsBlocksInd.v b/erasure/theories/EWcbvEvalCstrsAsBlocksInd.v index ff7801f00..75b312bed 100644 --- a/erasure/theories/EWcbvEvalCstrsAsBlocksInd.v +++ b/erasure/theories/EWcbvEvalCstrsAsBlocksInd.v @@ -36,8 +36,8 @@ Section OnSubterm. | on_lambda na t : has_tLambda -> Q (S n) t -> on_subterms Q n (tLambda na t) | on_letin na t u : has_tLetIn -> Q n t -> Q (S n) u -> on_subterms Q n (tLetIn na t u) | on_app f u : has_tApp -> Q n f -> Q n u -> on_subterms Q n (tApp f u) - | on_cstr i k args : has_tConstruct -> All (Q n) args -> on_subterms Q n (tConstruct i k args) - | on_case ci discr brs : has_tCase -> Q n discr -> + | on_cstr i k args : has_tConstruct -> All (Q n) args -> on_subterms Q n (tConstruct i k args) + | on_case ci discr brs : has_tCase -> Q n discr -> All (fun br => Q (#|br.1| + n) br.2) brs -> on_subterms Q n (tCase ci discr brs) | on_proj p c : has_tProj -> Q n c -> on_subterms Q n (tProj p c) | on_fix mfix idx : has_tFix -> All (fun d => Q (#|mfix| + n) d.(dbody)) mfix -> on_subterms Q n (tFix mfix idx) @@ -51,7 +51,7 @@ Class Qpres {etfl : ETermFlags} (Q : nat -> term -> Type) := qpres : forall n t, Class Qapp {etfl : ETermFlags} (Q : nat -> term -> Type) := qapp : has_tApp -> forall n f args, Q n (mkApps f args) <~> Q n f × All (Q n) args. #[export] Hint Mode Qapp - ! : typeclass_instances. -Class Qcase {etfl : ETermFlags} (Q : nat -> term -> Type) := qcase : has_tCase -> +Class Qcase {etfl : ETermFlags} (Q : nat -> term -> Type) := qcase : has_tCase -> forall n ci discr brs, Q n (tCase ci discr brs) -> forall discr', Q n discr' -> Q n (tCase ci discr' brs). #[export] Hint Mode Qcase - ! : typeclass_instances. @@ -68,22 +68,22 @@ Class Qcofix {etfl : ETermFlags} (Q : nat -> term -> Type) := qcofix : has_tCoFi #[export] Hint Mode Qcofix - ! : typeclass_instances. Class Qsubst (Q : nat -> term -> Type) := qsubst : forall t l, Q (#|l|) t -> All (Q 0) l -> Q 0 (substl l t). #[export] Hint Mode Qsubst ! : typeclass_instances. -Class Qfixs (Q : nat -> term -> Type) := qfixs : forall mfix idx, Q 0 (tFix mfix idx) -> +Class Qfixs (Q : nat -> term -> Type) := qfixs : forall mfix idx, Q 0 (tFix mfix idx) -> forall args fn, cunfold_fix mfix idx = Some (args, fn) -> Q 0 fn. #[export] Hint Mode Qfixs ! : typeclass_instances. -Class Qcofixs (Q : nat -> term -> Type) := qcofixs : forall mfix idx, Q 0 (tCoFix mfix idx) -> +Class Qcofixs (Q : nat -> term -> Type) := qcofixs : forall mfix idx, Q 0 (tCoFix mfix idx) -> forall args fn, cunfold_cofix mfix idx = Some (args, fn) -> Q 0 fn. #[export] Hint Mode Qcofixs ! : typeclass_instances. - + Lemma Qfix_subst {etfl : ETermFlags} mfix Q : has_tFix -> Qfix Q -> Qpres Q -> forall idx, idx < #|mfix| -> Q 0 (tFix mfix idx) -> All (Q 0) (fix_subst mfix). Proof. intros hasfix qfix qpre; unfold fix_subst. generalize (Nat.le_refl #|mfix|). generalize #|mfix| at 1 4. induction n. intros. constructor; auto. - intros. constructor. eapply qfix => //. 2:tea. tea. + intros. constructor. eapply qfix => //. 2:tea. tea. eapply IHn. lia. 2:tea. assumption. Qed. @@ -93,7 +93,7 @@ Proof. generalize (Nat.le_refl #|mfix|). generalize #|mfix| at 1 4. induction n. intros. constructor; auto. - intros. constructor. eapply qcofix => //. 2:tea. tea. + intros. constructor. eapply qcofix => //. 2:tea. tea. eapply IHn. lia. 2:tea. assumption. Qed. @@ -112,7 +112,7 @@ Proof. eapply qpres in hfix. depelim hfix. depelim i0. eapply nth_error_all in a; tea. now rewrite Nat.add_0_r in a. assumption. Qed. - + #[export] Instance Qsubst_Qcofixs {etfl : ETermFlags} Q : Qpres Q -> Qcofix Q -> Qsubst Q -> Qcofixs Q. Proof. move=> qpres qfix; rewrite /Qsubst /Qfixs. @@ -128,9 +128,9 @@ Proof. eapply qpres in hfix. depelim hfix. depelim i0. eapply nth_error_all in a; tea. now rewrite Nat.add_0_r in a. assumption. Qed. - + Class Qconst Σ (Q : nat -> term -> Type) := qconst : - ∀ kn decl, declared_constant Σ kn decl → + ∀ kn decl, declared_constant Σ kn decl → match cst_body decl with | None => unit | Some b => Q 0 b @@ -150,7 +150,7 @@ Class Qpreserves {etfl : ETermFlags} (Q : nat -> term -> Type) Σ := Set Warnings "+future-coercion-class-field". Lemma eval_preserve_mkApps_ind : -∀ (wfl : WcbvFlags), with_constructor_as_block = true -> forall {efl : EEnvFlags} (Σ : global_declarations) +∀ (wfl : WcbvFlags), with_constructor_as_block = true -> forall {efl : EEnvFlags} (Σ : global_declarations) (P' : term → term → Type) (Q : nat -> term -> Type) {Qpres : Qpreserves Q Σ} @@ -161,9 +161,9 @@ Lemma eval_preserve_mkApps_ind : (∀ (a t t' : term), eval Σ a tBox -> P a tBox → - eval Σ t t' → P t t' → P' (tApp a t) tBox) → + eval Σ t t' → P t t' → P' (tApp a t) tBox) → (∀ (f0 : term) (na : name) (b a a' res : term), - eval Σ f0 (tLambda na b) → + eval Σ f0 (tLambda na b) → P f0 (tLambda na b) → eval Σ a a' → P a a' @@ -174,25 +174,25 @@ Lemma eval_preserve_mkApps_ind : → P b0 b0' -> Q 1 b1 → eval Σ (ECSubst.csubst b0' 0 b1) res - → P (ECSubst.csubst b0' 0 b1) res → + → P (ECSubst.csubst b0' 0 b1) res → P' (tLetIn na b0 b1) res) - → (∀ (ind : inductive) (pars : nat) cdecl (discr : term) - (c : nat) (args : list term) (brs : - list - (list name × term)) + → (∀ (ind : inductive) (pars : nat) cdecl (discr : term) + (c : nat) (args : list term) (brs : + list + (list name × term)) (br : list name × term) (res : term), eval Σ discr (tConstruct ind c args) → P discr (tConstruct ind c args) → constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl) → nth_error brs c = Some br - → #|args| = pars + cdecl.(cstr_nargs) + → #|args| = pars + cdecl.(cstr_nargs) → #|skipn pars args| = #|br.1| -> Q #|br.1| br.2 → eval Σ (iota_red pars args br) res → P (iota_red pars args br) res → P' (tCase (ind, pars) discr brs) res) - → (∀ (ind : inductive) (pars : nat) (discr : term) - (brs : list (list name × term)) + → (∀ (ind : inductive) (pars : nat) (discr : term) + (brs : list (list name × term)) (n : list name) (f3 res : term), with_prop_case → eval Σ discr tBox @@ -204,8 +204,8 @@ Lemma eval_preserve_mkApps_ind : res → P (ECSubst.substl (repeat tBox #|n|) f3) res → P' (tCase (ind, pars) discr brs) res) - → (∀ (f4 : term) (mfix : mfixpoint term) - (idx : nat) (argsv : list term) + → (∀ (f4 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) (a av fn res : term), with_guarded_fix -> eval Σ f4 (mkApps (tFix mfix idx) argsv) @@ -217,8 +217,8 @@ Lemma eval_preserve_mkApps_ind : → eval Σ (tApp (mkApps fn argsv) av) res → P (tApp (mkApps fn argsv) av) res → P' (tApp f4 a) res) - → (∀ (f5 : term) (mfix : mfixpoint term) - (idx : nat) (argsv : list term) + → (∀ (f5 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) (a av : term) (narg : nat) (fn : term), with_guarded_fix -> eval Σ f5 (mkApps (tFix mfix idx) argsv) @@ -230,7 +230,7 @@ Lemma eval_preserve_mkApps_ind : → P' (tApp f5 a) (tApp (mkApps (tFix mfix idx) argsv) av)) - → (∀ (f5 : term) (mfix : mfixpoint term) + → (∀ (f5 : term) (mfix : mfixpoint term) (idx : nat) (a av : term) (narg : nat) (fn : term) res, with_guarded_fix = false -> eval Σ f5 (tFix mfix idx) @@ -239,13 +239,13 @@ Lemma eval_preserve_mkApps_ind : -> eval Σ a av -> P a av → eval Σ (tApp fn av) res → P (tApp fn av) res - → P' (tApp f5 a) res) → - - (∀ (ip : inductive × nat) (mfix : mfixpoint term) - (idx : nat) (args : list term) - (narg : nat) discr (fn : term) (brs : - list - (list name × term)) + → P' (tApp f5 a) res) → + + (∀ (ip : inductive × nat) (mfix : mfixpoint term) + (idx : nat) (args : list term) + (narg : nat) discr (fn : term) (brs : + list + (list name × term)) (res : term), cunfold_cofix mfix idx = Some (narg, fn) -> eval Σ discr (mkApps (tCoFix mfix idx) args) @@ -255,8 +255,8 @@ Lemma eval_preserve_mkApps_ind : → P' (tCase ip discr brs) res) - → (∀ (p : projection) (mfix : mfixpoint term) - (idx : nat) (args : list term) + → (∀ (p : projection) (mfix : mfixpoint term) + (idx : nat) (args : list term) (narg : nat) discr (fn res : term), has_tProj -> cunfold_cofix mfix idx = Some (narg, fn) @@ -266,7 +266,7 @@ Lemma eval_preserve_mkApps_ind : → P (tProj p (mkApps fn args)) res → P' (tProj p discr) res) - → (∀ (c : kername) (decl : constant_body) + → (∀ (c : kername) (decl : constant_body) (body : term), declared_constant Σ c decl → ∀ res : term, @@ -277,7 +277,7 @@ Lemma eval_preserve_mkApps_ind : has_tProj -> eval Σ discr (tConstruct p.(proj_ind) 0 args) → P discr (tConstruct p.(proj_ind) 0 args) - → constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) + → constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) → #|args| = p.(proj_npars) + cdecl.(cstr_nargs) -> nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a -> eval Σ a res @@ -291,19 +291,19 @@ Lemma eval_preserve_mkApps_ind : → inductive_isprop_and_pars Σ p.(proj_ind) = Some (true, p.(proj_npars)) → P' (tProj p discr) tBox) → (∀ (f11 f' : term) a a', - forall (ev : eval Σ f11 f'), - P f11 f' -> + forall (ev : eval Σ f11 f'), + P f11 f' -> (forall t u (ev' : eval Σ t u), eval_depth ev' <= eval_depth ev -> Q 0 t -> P t u) → - ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f' - || isConstructApp f' || isPrimApp f') → - eval Σ a a' → P a a' → - P' (tApp f11 a) (tApp f' a')) → + ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f' + || isConstructApp f' || isPrimApp f') → + eval Σ a a' → P a a' → + P' (tApp f11 a) (tApp f' a')) → (∀ ind i mdecl idecl cdecl args args', lookup_constructor Σ ind i = Some (mdecl, idecl, cdecl) -> #|args| = cstr_arity mdecl cdecl -> All2 (eval Σ) args args' -> All2 P args args' -> - P' (tConstruct ind i args) (tConstruct ind i args')) → + P' (tConstruct ind i args) (tConstruct ind i args')) → (∀ t : term, atom Σ t → Q 0 t -> P' t t) -> ∀ (t t0 : term), Q 0 t -> eval Σ t t0 → P' t t0. @@ -327,18 +327,18 @@ Proof. rename X15 into qt. rename X13 into Xcappexp. rename X14 into Qatom. clear t t0 qt H. - intros (t & t0 & qt & ev). + intros (t & t0 & qt & ev). intros IH. set (IH' t t0 q H := IH (t; t0; q; H)). clearbody IH'; clear IH; rename IH' into IH. cbn in IH. unfold MR in IH; cbn in IH. cbn. - Ltac ih := - match goal with + Ltac ih := + match goal with [ IH : forall x y, ?Q 0 x -> _ |- _ ] => unshelve eapply IH; tea; cbn; try lia end. Ltac hp' P'Q := intros ?; repeat split => //; try eapply P'Q; tea. assert (and_assum : forall x y, P' x y -> ((P' x y) -> Q 0 x × Q 0 y) -> - P x y). + P x y). { intuition auto. red. intuition auto. } Ltac ih' P'Q := match goal with @@ -346,9 +346,9 @@ Proof. eapply H; tea; (apply and_assum; [ih|hp' P'Q]) end. Ltac myt hyp anda P'Q := eapply hyp; tea; (apply and_assum; [ih|hp' P'Q]). - + destruct ev. - 1-18:eapply qpres in qt as qt'; depelim qt' => //. + 1-18:eapply qpres in qt as qt'; depelim qt' => //. all:try congruence. - eapply X; tea; (apply and_assum; [ih|hp' P'Q]). - assert (ql : Q 0 (tLambda na b)). @@ -371,7 +371,7 @@ Proof. rewrite -(List.rev_length (skipn pars args)) in a. rewrite Nat.add_0_r in a. eapply (qsubst _ (List.rev (skipn pars args))) in a. - 2:{ eapply All_rev, All_skipn. + 2:{ eapply All_rev, All_skipn. assert (Q 0 (tConstruct ind c args)). eapply P'Q; tea; ih. eapply qpres in X13. depelim X13 => //. } @@ -395,7 +395,7 @@ Proof. { rewrite -[tApp _ _](mkApps_app _ _ [av]). unshelve eapply (qapp _ _ _ _).2; auto. split => //. - eapply (qfixs mfix idx) in hfix; tea. + eapply (qfixs mfix idx) in hfix; tea. eapply All_app_inv => //. eapply All_tip.1. eapply P'Q; tea; ih. } eapply X4; tea. 1-3:(apply and_assum; [ih|hp' P'Q]). @@ -412,7 +412,7 @@ Proof. pose proof (ev1' := ev1). eapply P'Q in ev1' => //. eapply qapp in ev1' as [hfix qargs] => //. eapply qapp => //. split => //. - eapply (qcofixs mfix idx) in hfix; tea. + eapply (qcofixs mfix idx) in hfix; tea. clear ev1'; ih. } eapply X7; tea; (apply and_assum; [ih|hp' P'Q]). - cbn in IH. @@ -441,7 +441,7 @@ Proof. apply and_assum; [ih|hp' P'Q]. eapply IHa. cbn. intros. eapply (IH _ _ q H). cbn. lia. now depelim a0. - - eapply (X12 _ _ _ _ ev1); tea. + - eapply (X12 _ _ _ _ ev1); tea. 1,3:(apply and_assum; [ih|hp' P'Q]). intros. apply and_assum; [ih|hp' P'Q]. - eapply Qatom; tea. @@ -456,7 +456,7 @@ Proof. rtoProp; intuition auto. constructor => //. eapply on_evar; rtoProp; intuition auto. solve_all. - eapply on_lambda;rtoProp; intuition auto. + eapply on_lambda;rtoProp; intuition auto. eapply on_letin; rtoProp; intuition auto. eapply on_app; rtoProp; intuition auto. constructor => //; rtoProp; intuition auto. @@ -472,7 +472,7 @@ Proof. - red. intros kn decl. move/(lookup_env_wellformed clΣ). unfold wf_global_decl. destruct cst_body => //. - - red. move=> hasapp n t args. rewrite wellformed_mkApps //. + - red. move=> hasapp n t args. rewrite wellformed_mkApps //. split; intros; rtoProp; intuition auto; solve_all. - red. move=> hascase n ci discr brs. simpl. diff --git a/erasure/theories/EWcbvEvalEtaInd.v b/erasure/theories/EWcbvEvalEtaInd.v index f58a2ea6b..7af660c4b 100644 --- a/erasure/theories/EWcbvEvalEtaInd.v +++ b/erasure/theories/EWcbvEvalEtaInd.v @@ -37,7 +37,7 @@ Section OnSubterm. | on_lambda na t : has_tLambda -> Q (S n) t -> on_subterms Q n (tLambda na t) | on_letin na t u : has_tLetIn -> Q n t -> Q (S n) u -> on_subterms Q n (tLetIn na t u) | on_app f u : has_tApp -> Q n f -> Q n u -> on_subterms Q n (tApp f u) - | on_case ci discr brs : has_tCase -> Q n discr -> + | on_case ci discr brs : has_tCase -> Q n discr -> All (fun br => Q (#|br.1| + n) br.2) brs -> on_subterms Q n (tCase ci discr brs) | on_proj p c : has_tProj -> Q n c -> on_subterms Q n (tProj p c) | on_fix mfix idx : has_tFix -> All (fun d => Q (#|mfix| + n) d.(dbody)) mfix -> on_subterms Q n (tFix mfix idx) @@ -51,7 +51,7 @@ Class Qpres {etfl : ETermFlags} (Q : nat -> term -> Type) := qpres : forall n t, Class Qapp {etfl : ETermFlags} (Q : nat -> term -> Type) := qapp : has_tApp -> forall n f args, Q n (mkApps f args) <~> Q n f × All (Q n) args. #[export] Hint Mode Qapp - ! : typeclass_instances. -Class Qcase {etfl : ETermFlags} (Q : nat -> term -> Type) := qcase : has_tCase -> +Class Qcase {etfl : ETermFlags} (Q : nat -> term -> Type) := qcase : has_tCase -> forall n ci discr brs, Q n (tCase ci discr brs) -> forall discr', Q n discr' -> Q n (tCase ci discr' brs). #[export] Hint Mode Qcase - ! : typeclass_instances. @@ -64,22 +64,22 @@ Class Qcofix {etfl : ETermFlags} (Q : nat -> term -> Type) := qcofix : has_tCoFi #[export] Hint Mode Qcofix - ! : typeclass_instances. Class Qsubst (Q : nat -> term -> Type) := qsubst : forall t l, Q (#|l|) t -> All (Q 0) l -> Q 0 (substl l t). #[export] Hint Mode Qsubst ! : typeclass_instances. -Class Qfixs (Q : nat -> term -> Type) := qfixs : forall mfix idx, Q 0 (tFix mfix idx) -> +Class Qfixs (Q : nat -> term -> Type) := qfixs : forall mfix idx, Q 0 (tFix mfix idx) -> forall args fn, cunfold_fix mfix idx = Some (args, fn) -> Q 0 fn. #[export] Hint Mode Qfixs ! : typeclass_instances. -Class Qcofixs (Q : nat -> term -> Type) := qcofixs : forall mfix idx, Q 0 (tCoFix mfix idx) -> +Class Qcofixs (Q : nat -> term -> Type) := qcofixs : forall mfix idx, Q 0 (tCoFix mfix idx) -> forall args fn, cunfold_cofix mfix idx = Some (args, fn) -> Q 0 fn. #[export] Hint Mode Qcofixs ! : typeclass_instances. - + Lemma Qfix_subst {etfl : ETermFlags} mfix Q : has_tFix -> Qfix Q -> Qpres Q -> forall idx, idx < #|mfix| -> Q 0 (tFix mfix idx) -> All (Q 0) (fix_subst mfix). Proof. intros hasfix qfix qpre; unfold fix_subst. generalize (Nat.le_refl #|mfix|). generalize #|mfix| at 1 4. induction n. intros. constructor; auto. - intros. constructor. eapply qfix => //. 2:tea. tea. + intros. constructor. eapply qfix => //. 2:tea. tea. eapply IHn. lia. 2:tea. assumption. Qed. @@ -89,7 +89,7 @@ Proof. generalize (Nat.le_refl #|mfix|). generalize #|mfix| at 1 4. induction n. intros. constructor; auto. - intros. constructor. eapply qcofix => //. 2:tea. tea. + intros. constructor. eapply qcofix => //. 2:tea. tea. eapply IHn. lia. 2:tea. assumption. Qed. @@ -126,7 +126,7 @@ Proof. Qed. Class Qconst Σ (Q : nat -> term -> Type) := qconst : - ∀ kn decl, declared_constant Σ kn decl → + ∀ kn decl, declared_constant Σ kn decl → match cst_body decl with | None => unit | Some b => Q 0 b @@ -146,7 +146,7 @@ Class Qpreserves {etfl : ETermFlags} (Q : nat -> term -> Type) Σ := Set Warnings "+future-coercion-class-field". Lemma eval_preserve_mkApps_ind : -∀ (wfl : WcbvFlags), with_constructor_as_block = false -> forall {efl : EEnvFlags} (Σ : global_declarations) +∀ (wfl : WcbvFlags), with_constructor_as_block = false -> forall {efl : EEnvFlags} (Σ : global_declarations) (P' : term → term → Type) (Q : nat -> term -> Type) {Qpres : Qpreserves Q Σ} @@ -158,9 +158,9 @@ Lemma eval_preserve_mkApps_ind : (∀ (a t t' : term), eval Σ a tBox -> P a tBox → - eval Σ t t' → P t t' → P' (tApp a t) tBox) → + eval Σ t t' → P t t' → P' (tApp a t) tBox) → (∀ (f0 : term) (na : name) (b a a' res : term), - eval Σ f0 (tLambda na b) → + eval Σ f0 (tLambda na b) → P f0 (tLambda na b) → eval Σ a a' → P a a' @@ -172,26 +172,26 @@ Lemma eval_preserve_mkApps_ind : -> isEtaExp Σ b1 -> Q 1 b1 → eval Σ (ECSubst.csubst b0' 0 b1) res - → P (ECSubst.csubst b0' 0 b1) res → + → P (ECSubst.csubst b0' 0 b1) res → P' (tLetIn na b0 b1) res) - → (∀ (ind : inductive) (pars : nat) cdecl (discr : term) - (c : nat) (args : list term) (brs : - list - (list name × term)) + → (∀ (ind : inductive) (pars : nat) cdecl (discr : term) + (c : nat) (args : list term) (brs : + list + (list name × term)) (br : list name × term) (res : term), forallb (λ x : list name × term, isEtaExp Σ x.2) brs -> eval Σ discr (mkApps (tConstruct ind c []) args) → P discr (mkApps (tConstruct ind c []) args) → constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl) → nth_error brs c = Some br - → #|args| = pars + cdecl.(cstr_nargs) + → #|args| = pars + cdecl.(cstr_nargs) → #|skipn pars args| = #|br.1| -> Q #|br.1| br.2 → eval Σ (iota_red pars args br) res → P (iota_red pars args br) res → P' (tCase (ind, pars) discr brs) res) - → (∀ (ind : inductive) (pars : nat) (discr : term) - (brs : list (list name × term)) + → (∀ (ind : inductive) (pars : nat) (discr : term) + (brs : list (list name × term)) (n : list name) (f3 res : term), with_prop_case → eval Σ discr tBox @@ -204,8 +204,8 @@ Lemma eval_preserve_mkApps_ind : res → P (ECSubst.substl (repeat tBox #|n|) f3) res → P' (tCase (ind, pars) discr brs) res) - → (∀ (f4 : term) (mfix : mfixpoint term) - (idx : nat) (argsv : list term) + → (∀ (f4 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) (a av fn res : term), with_guarded_fix -> eval Σ f4 (mkApps (tFix mfix idx) argsv) @@ -218,8 +218,8 @@ Lemma eval_preserve_mkApps_ind : → eval Σ (tApp (mkApps fn argsv) av) res → P (tApp (mkApps fn argsv) av) res → P' (tApp f4 a) res) - → (∀ (f5 : term) (mfix : mfixpoint term) - (idx : nat) (argsv : list term) + → (∀ (f5 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) (a av : term) (narg : nat) (fn : term), with_guarded_fix -> eval Σ f5 (mkApps (tFix mfix idx) argsv) @@ -232,7 +232,7 @@ Lemma eval_preserve_mkApps_ind : → P' (tApp f5 a) (tApp (mkApps (tFix mfix idx) argsv) av)) - → (∀ (f5 : term) (mfix : mfixpoint term) + → (∀ (f5 : term) (mfix : mfixpoint term) (idx : nat) (a av : term) (narg : nat) (fn : term) res, with_guarded_fix = false -> eval Σ f5 (tFix mfix idx) @@ -243,13 +243,13 @@ Lemma eval_preserve_mkApps_ind : → eval Σ (tApp fn av) res → P (tApp fn av) res -> isEtaExp Σ (tApp f5 a) - → P' (tApp f5 a) res) → - - (∀ (ip : inductive × nat) (mfix : mfixpoint term) - (idx : nat) (args : list term) - (narg : nat) discr (fn : term) (brs : - list - (list name × term)) + → P' (tApp f5 a) res) → + + (∀ (ip : inductive × nat) (mfix : mfixpoint term) + (idx : nat) (args : list term) + (narg : nat) discr (fn : term) (brs : + list + (list name × term)) (res : term), cunfold_cofix mfix idx = Some (narg, fn) -> isEtaExp Σ fn @@ -262,8 +262,8 @@ Lemma eval_preserve_mkApps_ind : → P' (tCase ip discr brs) res) - → (∀ (p : projection) (mfix : mfixpoint term) - (idx : nat) (args : list term) + → (∀ (p : projection) (mfix : mfixpoint term) + (idx : nat) (args : list term) (narg : nat) discr (fn res : term), has_tProj -> cunfold_cofix mfix idx = Some (narg, fn) @@ -275,7 +275,7 @@ Lemma eval_preserve_mkApps_ind : → P (tProj p (mkApps fn args)) res → P' (tProj p discr) res) - → (∀ (c : kername) (decl : constant_body) + → (∀ (c : kername) (decl : constant_body) (body : term), declared_constant Σ c decl → ∀ res : term, @@ -287,7 +287,7 @@ Lemma eval_preserve_mkApps_ind : eval Σ discr (mkApps (tConstruct p.(proj_ind) 0 []) args) → P discr (mkApps (tConstruct p.(proj_ind) 0 []) args) - → constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) + → constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) → #|args| = p.(proj_npars) + cdecl.(cstr_nargs) -> nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a -> eval Σ a res @@ -301,14 +301,14 @@ Lemma eval_preserve_mkApps_ind : → inductive_isprop_and_pars Σ p.(proj_ind) = Some (true, p.(proj_npars)) → P' (tProj p discr) tBox) → (∀ (f11 f' : term) a a', - forall (ev : eval Σ f11 f'), - P f11 f' -> + forall (ev : eval Σ f11 f'), + P f11 f' -> (forall t u (ev' : eval Σ t u), eval_depth ev' <= eval_depth ev -> Q 0 t -> isEtaExp Σ t -> P t u) → - ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f' || isConstructApp f' || - isPrimApp f') → - eval Σ a a' → P a a' → + ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f' || isConstructApp f' || + isPrimApp f') → + eval Σ a a' → P a a' → isEtaExp Σ (tApp f' a') -> - P' (tApp f11 a) (tApp f' a')) → + P' (tApp f11 a) (tApp f' a')) → (∀ ind i mdecl idecl cdecl args args', lookup_constructor Σ ind i = Some (mdecl, idecl, cdecl) -> #|args| = cstr_arity mdecl cdecl -> @@ -317,7 +317,7 @@ Lemma eval_preserve_mkApps_ind : Q 0 (mkApps (tConstruct ind i []) args) -> Q 0 (mkApps (tConstruct ind i []) args') -> All2 P args args' -> - P' (mkApps (tConstruct ind i []) args) (mkApps (tConstruct ind i []) args')) → + P' (mkApps (tConstruct ind i []) args) (mkApps (tConstruct ind i []) args')) → (∀ t : term, atom Σ t → Q 0 t -> isEtaExp Σ t -> P' t t) -> ∀ (t t0 : term), Q 0 t -> isEtaExp Σ t -> eval Σ t t0 → P' t t0. @@ -344,23 +344,23 @@ Proof. rename X15 into qt. rename X13 into Xcappexp. rename X14 into Qatom. clear t t0 qt H0. - intros (t & t0 & qt & ev). + intros (t & t0 & qt & ev). intros IH. set (IH' t t0 q H := IH (t; t0; q; H)). clearbody IH'; clear IH; rename IH' into IH. Opaque isEtaExp. cbn in IH. unfold MR in IH; cbn in IH. cbn. - Ltac ih := - match goal with + Ltac ih := + match goal with [ IH : forall x y, ?Q 0 x -> _ |- _ ] => unshelve eapply IH; tea; cbn; try lia end. - Ltac iheta e := - match goal with + Ltac iheta e := + match goal with [ IH : forall x y, ?Q 0 x -> _ |- _ ] => unshelve eapply (IH _ _ e); tea; cbn; try lia end. Ltac hp' P'Q := intros [hp' heta]; repeat split => //; try eapply P'Q; tea. - assert (and_assum : forall x y, (P' x y × isEtaExp Σ y) -> + assert (and_assum : forall x y, (P' x y × isEtaExp Σ y) -> ((P' x y × isEtaExp Σ y) -> Q 0 x × Q 0 y × isEtaExp Σ x) -> - P x y). + P x y). { intuition auto. red. intuition auto. } Ltac ih' P'Q := match goal with @@ -368,7 +368,7 @@ Proof. eapply H; tea; (apply and_assum; [ih|hp' P'Q]) end. destruct ev. - 1-18:eapply qpres in qt as qt'; depelim qt' => //. + 1-18:eapply qpres in qt as qt'; depelim qt' => //. - move/isEtaExp_tApp. destruct decompose_app as [hd args] eqn:da. destruct (construct_viewc hd) eqn:cv. @@ -384,7 +384,7 @@ Proof. * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs. clear IH; rewrite ha in ev1. elimtype False. eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto. - * move=> /and4P [] etat0 etaargs etaa etat. + * move=> /and4P [] etat0 etaargs etaa etat. assert (ql : Q 0 (tLambda na b)). { eapply P'Q; tea. ih. } assert (qs: Q 0 (csubst a' 0 b)). @@ -421,7 +421,7 @@ Proof. rewrite -(List.rev_length (skipn pars args)) in a. rewrite Nat.add_0_r in a. eapply (qsubst _ (List.rev (skipn pars args))) in a. - 2:{ eapply All_rev, All_skipn. + 2:{ eapply All_rev, All_skipn. assert (Q 0 (mkApps (tConstruct ind c []) args)). eapply P'Q; tea; ih. eapply qapp in X13; tea. eapply X13. } @@ -448,7 +448,7 @@ Proof. * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs. clear IH; rewrite ha in ev1. elimtype False. eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto. - * move=> /and4P [] etat0 etaargs etaa etat. + * move=> /and4P [] etat0 etaargs etaa etat. pose proof (ev1' := ev1). eapply P'Q in ev1' => //. 2:{ clear ev1'; ih. } eapply qapp in ev1' as [hfix qargs] => //. assert (hastfix : has_tFix). @@ -459,7 +459,7 @@ Proof. { rewrite -[tApp _ _](mkApps_app _ _ [av]). unshelve eapply (qapp _ _ _ _).2; auto. split => //. - eapply (qfixs mfix idx) in hfix; tea. + eapply (qfixs mfix idx) in hfix; tea. eapply All_app_inv => //. eapply All_tip.1. eapply P'Q; tea; ih. } assert (etaapp : isEtaExp Σ fn × isEtaExp Σ (tApp (mkApps fn argsv) av)). @@ -470,7 +470,7 @@ Proof. apply MCProd.and_assum. eapply isEtaExp_cunfold_fix. now simp_eta in efix. exact e. intros hfn. - eapply isEtaExp_mkApps_intro => //. + eapply isEtaExp_mkApps_intro => //. eapply All_app_inv. now eapply forallb_All in hargs. eapply (fst All_tip). iheta q0. } destruct etaapp as [etafn etafnapp]. @@ -498,7 +498,7 @@ Proof. * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs. clear IH; rewrite ha in ev1. elimtype False. eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto. - * move=> /and4P [] etat0 etaargs etaa etat. + * move=> /and4P [] etat0 etaargs etaa etat. assert (qav : Q 0 av). { eapply P'Q; tea; ih. } assert (qa : Q 0 (tApp fn av)). @@ -524,7 +524,7 @@ Proof. pose proof (ev1' := ev1). eapply P'Q in ev1' => //. eapply qapp in ev1' as [hfix qargs] => //. eapply qapp => //. split => //. - eapply (qcofixs mfix idx) in hfix; tea. + eapply (qcofixs mfix idx) in hfix; tea. clear ev1'; ih. } assert (etafn : isEtaExp Σ fn && forallb (isEtaExp Σ) args). { assert (hfix : isEtaExp Σ (mkApps (tCoFix mfix idx) args)) by iheta q. @@ -620,7 +620,7 @@ Proof. eapply All2_All_right; tea; cbn. intros ? ? [? [? [? []]]]. split. eapply P'Q; tea. apply p. apply p. } eapply mkApps_eq_inj in e1 as [] => //. subst ex. noconf H. - split. + split. unshelve eapply Xcappexp; tea. + rewrite ht -remove_last_last //. move: etaind; rewrite /isEtaExp_app. @@ -632,7 +632,7 @@ Proof. constructor; [|constructor]. apply ev2. + rewrite ht. rewrite -remove_last_last //. + eapply qapp in q as []; auto. - eapply qapp => //. + eapply qapp => //. + eapply qapp in q as [] => //. eapply qapp; auto. split => //. eapply All_impl; tea; cbn; intuition auto. + eapply All2_All_mix_left in X16; [|exact X14]. @@ -647,7 +647,7 @@ Proof. rewrite ht -remove_last_last //. rtoProp. split. eauto. eapply All_forallb. eapply All_impl; tea. cbn; intuition auto. auto. - * move=> /and4P [] etat0 etaargs etaa etat. + * move=> /and4P [] etat0 etaargs etaa etat. rewrite -[tApp _ a'](mkApps_app _ _ [a']). assert (P' f (mkApps (tConstruct ind c []) cargs) × isEtaExp Σ (mkApps (tConstruct ind c []) cargs)). { unshelve eapply IH; tea. cbn. lia. } @@ -667,8 +667,8 @@ Proof. subst f. exfalso. eapply eval_mkApps_Construct_inv in ev1' as [? [hf' hargs']]. subst f'. clear IH; move: i; rewrite !negb_or isConstructApp_mkApps /= !andb_false_r //. auto. - * move=> /and4P [] etat0 etaargs etaa etat. - split. eapply (X12 _ _ _ _ ev1); tea. + * move=> /and4P [] etat0 etaargs etaa etat. + split. eapply (X12 _ _ _ _ ev1); tea. 1,3:(apply and_assum; [ih|hp' P'Q]). intros. apply and_assum; [ih|hp' P'Q]. pose proof (decompose_app_inv da). clear cv. @@ -697,14 +697,14 @@ Definition term_flags := has_tCoFix := false; has_tPrim := true |}. - -Definition env_flags := + +Definition env_flags := {| has_axioms := false; has_cstr_params := false; term_switches := term_flags ; cstr_as_blocks := false |}. - + From MetaCoq.Erasure Require Import ELiftSubst. Lemma Qpreserves_wellformed (efl : EEnvFlags) Σ : cstr_as_blocks = false -> @@ -729,7 +729,7 @@ Proof. - red. intros kn decl. move/(lookup_env_wellformed clΣ). unfold wf_global_decl. destruct cst_body => //. - - red. move=> hasapp n t args. rewrite wellformed_mkApps //. + - red. move=> hasapp n t args. rewrite wellformed_mkApps //. split; intros; rtoProp; intuition auto; solve_all. - red. intros. simpl in H0. simpl. rtoProp; intuition auto. - red. move=> hasproj n p discr. simpl; rtoProp; intuition auto. @@ -743,11 +743,11 @@ Proof. Qed. Ltac destruct_nary_times := - match goal with + match goal with | [ H : _ × _ |- _ ] => destruct H - | [ H : [× _, _ & _] |- _ ] => destruct H - | [ H : [× _, _, _ & _] |- _ ] => destruct H - | [ H : [× _, _, _, _ & _] |- _ ] => destruct H + | [ H : [× _, _ & _] |- _ ] => destruct H + | [ H : [× _, _, _ & _] |- _ ] => destruct H + | [ H : [× _, _, _, _ & _] |- _ ] => destruct H end. Lemma eval_etaexp {fl : WcbvFlags} (efl := env_flags) {Σ a a'} : @@ -759,7 +759,7 @@ Lemma eval_etaexp {fl : WcbvFlags} (efl := env_flags) {Σ a a'} : Proof. intros hcon etaΣ wfΣ wf ev eta. revert a a' wf eta ev. - eapply (eval_preserve_mkApps_ind (efl:=env_flags) fl hcon Σ (fun _ x => isEtaExp Σ x) (fun n t => wellformed Σ n t) + eapply (eval_preserve_mkApps_ind (efl:=env_flags) fl hcon Σ (fun _ x => isEtaExp Σ x) (fun n t => wellformed Σ n t) (Qpres := Qpreserves_wellformed env_flags Σ eq_refl wfΣ)) => //. all:intros; repeat destruct_nary_times. all:intuition auto. diff --git a/erasure/theories/EWcbvEvalInd.v b/erasure/theories/EWcbvEvalInd.v index 0680ec4b4..f53ab0e50 100644 --- a/erasure/theories/EWcbvEvalInd.v +++ b/erasure/theories/EWcbvEvalInd.v @@ -12,15 +12,15 @@ Local Set Keyed Unification. Hint Constructors eval : core. Section eval_mkApps_rect. - + Variables (wfl : WcbvFlags) (Σ : global_declarations) (P : term → term → Type). - Let IH x y (ev : eval Σ x y) := + Let IH x y (ev : eval Σ x y) := forall t u (ev' : eval Σ t u), eval_depth ev' <= eval_depth ev -> P t u. Lemma eval_mkApps_rect : (∀ a t t' : term, - forall ev : eval Σ a tBox, P a tBox → + forall ev : eval Σ a tBox, P a tBox → IH _ _ ev -> eval Σ t t' → P t t' → P (tApp a t) tBox) → (∀ (f0 : term) (na : BasicAst.name) (b a a' res : term), @@ -37,38 +37,38 @@ Section eval_mkApps_rect. → eval Σ (ECSubst.csubst b0' 0 b1) res → P (ECSubst.csubst b0' 0 b1) res → P (tLetIn na b0 b1) res) - → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) - (discr : term) (c : nat) (args : list term) - (brs : list (list name × term)) (br : list name × term) - (res : term) (e : with_constructor_as_block = false) + → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) + (discr : term) (c : nat) (args : list term) + (brs : list (list name × term)) (br : list name × term) + (res : term) (e : with_constructor_as_block = false) (e0 : eval Σ discr (mkApps (tConstruct ind c []) args)), - P discr (mkApps (tConstruct ind c []) args) + P discr (mkApps (tConstruct ind c []) args) → ∀ (e1 : constructor_isprop_pars_decl Σ ind c = - Some (false, pars, cdecl)) (e2 : - nth_error brs c = - Some br) - (e3 : #|args| = pars + cstr_nargs cdecl) - (e4 : #|skipn pars args| = #|br.1|) + Some (false, pars, cdecl)) (e2 : + nth_error brs c = + Some br) + (e3 : #|args| = pars + cstr_nargs cdecl) + (e4 : #|skipn pars args| = #|br.1|) (e5 : eval Σ (iota_red pars args br) res), P (iota_red pars args br) res → P (tCase (ind, pars) discr brs) res) - → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) - (discr : term) (c : nat) (args : list term) - (brs : list (list name × term)) (br : list name × term) - (res : term) (e : with_constructor_as_block = true) + → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) + (discr : term) (c : nat) (args : list term) + (brs : list (list name × term)) (br : list name × term) + (res : term) (e : with_constructor_as_block = true) (e0 : eval Σ discr (tConstruct ind c args)), - P discr (tConstruct ind c args) + P discr (tConstruct ind c args) → ∀ (e1 : constructor_isprop_pars_decl Σ ind c = - Some (false, pars, cdecl)) - (e2 : nth_error brs c = Some br) - (e3 : #|args| = pars + cstr_nargs cdecl) - (e4 : #|skipn pars args| = #|br.1|) + Some (false, pars, cdecl)) + (e2 : nth_error brs c = Some br) + (e3 : #|args| = pars + cstr_nargs cdecl) + (e4 : #|skipn pars args| = #|br.1|) (e5 : eval Σ (iota_red pars args br) res), - P (iota_red pars args br) res + P (iota_red pars args br) res → P (tCase (ind, pars) discr brs) res) - - → (∀ (ind : Kernames.inductive) (pars : nat) (discr : term) - (brs : list (list BasicAst.name × term)) + + → (∀ (ind : Kernames.inductive) (pars : nat) (discr : term) + (brs : list (list BasicAst.name × term)) (n : list BasicAst.name) (f3 res : term), with_prop_case → eval Σ discr tBox @@ -78,9 +78,9 @@ Section eval_mkApps_rect. → eval Σ (ECSubst.substl (repeat tBox #|n|) f3) res → P (ECSubst.substl (repeat tBox #|n|) f3) res → P (tCase (ind, pars) discr brs) res) - - → (∀ (f4 : term) (mfix : mfixpoint term) - (idx : nat) (argsv : list term) + + → (∀ (f4 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) (a av fn res : term), forall guarded : with_guarded_fix, forall ev : eval Σ f4 (mkApps (tFix mfix idx) argsv), @@ -92,21 +92,21 @@ Section eval_mkApps_rect. → eval Σ (tApp (mkApps fn argsv) av) res → P (tApp (mkApps fn argsv) av) res → P (tApp f4 a) res) - → (∀ (f5 : term) (mfix : mfixpoint term) - (idx : nat) (argsv : list term) + → (∀ (f5 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) (a av : term) (narg : nat) (fn : term), forall guarded : with_guarded_fix, forall ev : eval Σ f5 (mkApps (tFix mfix idx) argsv), - P f5 (mkApps (tFix mfix idx) argsv) + P f5 (mkApps (tFix mfix idx) argsv) → IH _ _ ev → eval Σ a av → P a av → cunfold_fix mfix idx = Some (narg, fn) → #|argsv| < narg → P (tApp f5 a) (tApp (mkApps (tFix mfix idx) argsv) av)) - → (∀ (f6 : term) (mfix : mfixpoint term) - (idx : nat) (a av fn res : term) (narg : nat) - (unguarded : with_guarded_fix = false) + → (∀ (f6 : term) (mfix : mfixpoint term) + (idx : nat) (a av fn res : term) (narg : nat) + (unguarded : with_guarded_fix = false) (ev : eval Σ f6 (tFix mfix idx)), P f6 (tFix mfix idx) → IH _ _ ev @@ -115,9 +115,9 @@ Section eval_mkApps_rect. → eval Σ (tApp fn av) res → P (tApp fn av) res → P (tApp f6 a) res) - → (∀ (ip : Kernames.inductive × nat) (mfix : mfixpoint term) - (idx : nat) (args : list term) - (narg : nat) discr (fn : term) (brs : list (list BasicAst.name × term)) + → (∀ (ip : Kernames.inductive × nat) (mfix : mfixpoint term) + (idx : nat) (args : list term) + (narg : nat) discr (fn : term) (brs : list (list BasicAst.name × term)) (res : term), cunfold_cofix mfix idx = Some (narg, fn) -> eval Σ discr (mkApps (tCoFix mfix idx) args) @@ -125,8 +125,8 @@ Section eval_mkApps_rect. → eval Σ (tCase ip (mkApps fn args) brs) res → P (tCase ip (mkApps fn args) brs) res → P (tCase ip discr brs) res) - → (∀ (p : Kernames.projection) (mfix : mfixpoint term) - (idx : nat) (args : list term) + → (∀ (p : Kernames.projection) (mfix : mfixpoint term) + (idx : nat) (args : list term) (narg : nat) discr (fn res : term), cunfold_cofix mfix idx = Some (narg, fn) -> eval Σ discr (mkApps (tCoFix mfix idx) args) @@ -141,45 +141,45 @@ Section eval_mkApps_rect. → eval Σ body res → P body res → P (tConst c) res) - → (∀ (p : projection) (cdecl : constructor_body) - (discr : term) (args : list term) + → (∀ (p : projection) (cdecl : constructor_body) + (discr : term) (args : list term) (a res : term) (e : with_constructor_as_block = - false) + false) (e0 : eval Σ discr (mkApps - (tConstruct + (tConstruct (proj_ind p) 0 []) args)), P discr (mkApps (tConstruct (proj_ind p) 0 []) - args) + args) → ∀ (e1 : constructor_isprop_pars_decl Σ (proj_ind p) 0 = - Some (false, proj_npars p, cdecl)) + Some (false, proj_npars p, cdecl)) (e2 : #|args| = - proj_npars p + cstr_nargs cdecl) + proj_npars p + cstr_nargs cdecl) (e3 : nth_error args - (proj_npars p + proj_arg p) = + (proj_npars p + proj_arg p) = Some a) (e4 : eval Σ a res), - P a res + P a res → P (tProj p discr) res) - → (∀ (p : projection) (cdecl : constructor_body) - (discr : term) (args : list term) - (a res : term) (e : + → (∀ (p : projection) (cdecl : constructor_body) + (discr : term) (args : list term) + (a res : term) (e : with_constructor_as_block = - true) + true) (e0 : eval Σ discr (tConstruct (proj_ind p) 0 args)), P discr (tConstruct (proj_ind p) 0 args) → ∀ (e1 : constructor_isprop_pars_decl Σ (proj_ind p) 0 = - Some (false, proj_npars p, cdecl)) + Some (false, proj_npars p, cdecl)) (e2 : #|args| = - proj_npars p + cstr_nargs cdecl) + proj_npars p + cstr_nargs cdecl) (e3 : nth_error args (proj_npars p + proj_arg p) = Some a) (e4 : eval Σ a res), - P a res + P a res → P (tProj p discr) res) → (∀ p (discr : term), @@ -189,15 +189,15 @@ Section eval_mkApps_rect. → inductive_isprop_and_pars Σ p.(proj_ind) = Some (true, p.(proj_npars)) → P (tProj p discr) tBox) - → (∀ (ind : inductive) - (c : nat) (mdecl : mutual_inductive_body) - (idecl : one_inductive_body) - (cdecl : constructor_body) - (f14 : term) (args : list term) - (a a' : term) - (e : with_constructor_as_block = false) + → (∀ (ind : inductive) + (c : nat) (mdecl : mutual_inductive_body) + (idecl : one_inductive_body) + (cdecl : constructor_body) + (f14 : term) (args : list term) + (a a' : term) + (e : with_constructor_as_block = false) (e0 : lookup_constructor Σ ind c = - Some (mdecl, idecl, cdecl)) + Some (mdecl, idecl, cdecl)) (e1 : eval Σ f14 (mkApps (tConstruct ind c []) @@ -205,8 +205,8 @@ Section eval_mkApps_rect. IH _ _ e1 -> P f14 (mkApps (tConstruct ind c []) - args) - → ∀ (l : #|args| < cstr_arity mdecl cdecl) + args) + → ∀ (l : #|args| < cstr_arity mdecl cdecl) (e2 : eval Σ a a'), P a a' → P (tApp f14 a) @@ -215,15 +215,15 @@ Section eval_mkApps_rect. (tConstruct ind c []) args) a')) - → (∀ (ind : inductive) - (c : nat) (mdecl : mutual_inductive_body) - (idecl : one_inductive_body) - (cdecl : constructor_body) + → (∀ (ind : inductive) + (c : nat) (mdecl : mutual_inductive_body) + (idecl : one_inductive_body) + (cdecl : constructor_body) (args args' : list term) - (e : with_constructor_as_block = true) + (e : with_constructor_as_block = true) (e0 : lookup_constructor Σ ind c = - Some (mdecl, idecl, cdecl)) - (l : #|args| = cstr_arity mdecl cdecl) + Some (mdecl, idecl, cdecl)) + (l : #|args| = cstr_arity mdecl cdecl) (e1 : All2 (eval Σ) args args'), All2 P args args' → P (tConstruct ind c args) (tConstruct ind c args')) @@ -232,15 +232,15 @@ Section eval_mkApps_rect. P f15 f' -> IH _ _ e → ∀ (i : ~~ (isLambda f' - || + || (if with_guarded_fix then isFixApp f' - else isFix f') || - isBox f' || - isConstructApp f' || isPrimApp f')) + else isFix f') || + isBox f' || + isConstructApp f' || isPrimApp f')) (e0 : eval Σ a a'), P a a' - → P (tApp f15 a) + → P (tApp f15 a) (tApp f' a') ) → (∀ t : term, atom Σ t → P t t) @@ -261,7 +261,7 @@ Proof using Type. 2:{ apply p. apply measure_wf, lt_wf. } clear p. clear t t0 H. - intros (t & t0 & ev). + intros (t & t0 & ev). intros IH'. set (IH'' t t0 H := IH' (t; t0; H)). clearbody IH''; clear IH'; rename IH'' into IH'. cbn in IH'. unfold MR in IH'; cbn in IH'. cbn. @@ -280,4 +280,4 @@ Proof using Type. intros. eapply (IH' _ _ H). cbn. lia. Qed. -End eval_mkApps_rect. +End eval_mkApps_rect. diff --git a/erasure/theories/EWellformed.v b/erasure/theories/EWellformed.v index c1e2d74d9..3fccd987a 100644 --- a/erasure/theories/EWellformed.v +++ b/erasure/theories/EWellformed.v @@ -13,13 +13,13 @@ Set Equations Transparent. Local Set Keyed Unification. Require Import ssreflect ssrbool. -Definition isSome {A} (o : option A) := - match o with +Definition isSome {A} (o : option A) := + match o with | None => false | Some _ => true end. -Class ETermFlags := +Class ETermFlags := { has_tBox : bool ; has_tRel : bool ; has_tVar : bool @@ -45,7 +45,7 @@ Class EEnvFlags := { }. Set Warnings "+future-coercion-class-field". -Definition all_term_flags := +Definition all_term_flags := {| has_tBox := true ; has_tRel := true ; has_tVar := true @@ -62,20 +62,20 @@ Definition all_term_flags := ; has_tPrim := true |}. -Definition all_env_flags := +Definition all_env_flags := {| has_axioms := true; term_switches := all_term_flags; has_cstr_params := true ; cstr_as_blocks := false |}. - -Definition all_env_flags_blocks := + +Definition all_env_flags_blocks := {| has_axioms := true; term_switches := all_term_flags; has_cstr_params := true ; cstr_as_blocks := true |}. - + Section wf. - + Context {efl : EEnvFlags}. Variable Σ : global_context. @@ -86,12 +86,12 @@ Section wf. - all occuring constants are defined, and - if has_axioms is false, all occuring constants have bodies *) - Definition wf_fix_gen (wf : nat -> term -> bool) k mfix idx := - let k' := List.length mfix + k in + Definition wf_fix_gen (wf : nat -> term -> bool) k mfix idx := + let k' := List.length mfix + k in (idx true | _ => false end. - + Fixpoint wellformed k (t : term) : bool := match t with | tRel i => has_tRel && Nat.ltb i k @@ -99,22 +99,22 @@ Section wf. | tLambda _ M => has_tLambda && wellformed (S k) M | tApp u v => has_tApp && wellformed k u && wellformed k v | tLetIn na b b' => has_tLetIn && wellformed k b && wellformed (S k) b' - | tCase ind c brs => has_tCase && + | tCase ind c brs => has_tCase && let brs' := List.forallb (fun br => wellformed (#|br.1| + k) br.2) brs in isSome (lookup_inductive Σ ind.1) && wellformed k c && brs' | tProj p c => has_tProj && isSome (lookup_projection Σ p) && wellformed k c | tFix mfix idx => has_tFix && List.forallb (isLambda ∘ dbody) mfix && wf_fix_gen wellformed k mfix idx | tCoFix mfix idx => has_tCoFix && wf_fix_gen wellformed k mfix idx | tBox => has_tBox - | tConst kn => has_tConst && + | tConst kn => has_tConst && match lookup_constant Σ kn with | Some d => has_axioms || isSome d.(cst_body) - | _ => false + | _ => false end - | tConstruct ind c block_args => has_tConstruct && isSome (lookup_constructor Σ ind c) && - if cstr_as_blocks then match lookup_constructor_pars_args Σ ind c with - | Some (p, a) => (p + a) == #|block_args| - | _ => true end + | tConstruct ind c block_args => has_tConstruct && isSome (lookup_constructor Σ ind c) && + if cstr_as_blocks then match lookup_constructor_pars_args Σ ind c with + | Some (p, a) => (p + a) == #|block_args| + | _ => true end && forallb (wellformed k) block_args else is_nil block_args | tVar _ => has_tVar | tPrim _ => has_tPrim @@ -157,7 +157,7 @@ Definition wf_global_decl {efl : EEnvFlags} Σ d : bool := Inductive wf_glob {efl : EEnvFlags} : global_declarations -> Prop := | wf_glob_nil : wf_glob [] -| wf_glob_cons kn d Σ : +| wf_glob_cons kn d Σ : wf_glob Σ -> wf_global_decl Σ d -> fresh_global kn Σ -> @@ -170,7 +170,7 @@ Section EEnvFlags. Context {efl : EEnvFlags}. Context {Σ : global_declarations}. Notation wellformed := (wellformed Σ). - + Lemma wellformed_closed {k t} : wellformed k t -> closedn k t. Proof using Type. induction t in k |- * using EInduction.term_forall_list_ind; intros; @@ -182,7 +182,7 @@ Section EEnvFlags. destruct cstr_as_blocks. 2: destruct args; eauto; solve_all. rtoProp. solve_all. Qed. - + Lemma wellformed_closed_decl {t} : wf_global_decl Σ t -> closed_decl t. Proof using Type. destruct t => /= //. @@ -199,8 +199,8 @@ Section EEnvFlags. unfold wf_fix, test_def, test_snd in *; try solve [simpl lift; simpl closed; f_equal; auto; repeat (rtoProp; simpl in *; solve_all)]; try easy. - eapply Nat.ltb_lt. now eapply Nat.ltb_lt in H2. - - destruct cstr_as_blocks; eauto. solve_all. - destruct lookup_constructor_pars_args as [ [] |]; rtoProp; repeat solve_all. + - destruct cstr_as_blocks; eauto. solve_all. + destruct lookup_constructor_pars_args as [ [] |]; rtoProp; repeat solve_all. Qed. Lemma wellformed_lift n k k' t : wellformed k t -> wellformed (k + n) (lift n k' t). @@ -227,7 +227,7 @@ Section EEnvFlags. Qed. Lemma wellformed_subst_eq {s k k' t} : - forallb (wellformed k) s -> + forallb (wellformed k) s -> wellformed (k + k' + #|s|) t -> wellformed (k + k') (subst s k' t). Proof using Type. @@ -253,7 +253,7 @@ Section EEnvFlags. - f_equal. simpl. solve_all. specialize (IHt (S k')). rewrite <- Nat.add_succ_comm in IHt. - rewrite IHt //. + rewrite IHt //. - specialize (IHt2 (S k')). rewrite <- Nat.add_succ_comm in IHt2. eapply IHt2; auto. @@ -273,7 +273,7 @@ Section EEnvFlags. Qed. Lemma wellformed_subst s k t : - forallb (wellformed k) s -> wellformed (#|s| + k) t -> + forallb (wellformed k) s -> wellformed (#|s| + k) t -> wellformed k (subst0 s t). Proof using Type. intros. @@ -283,8 +283,8 @@ Section EEnvFlags. Qed. Lemma wellformed_csubst t k u : - wellformed 0 t -> - wellformed (S k) u -> + wellformed 0 t -> + wellformed (S k) u -> wellformed k (ECSubst.csubst t 0 u). Proof using Type. intros. @@ -295,8 +295,8 @@ Section EEnvFlags. Qed. Lemma wellformed_substl ts k u : - forallb (wellformed 0) ts -> - wellformed (#|ts| + k) u -> + forallb (wellformed 0) ts -> + wellformed (#|ts| + k) u -> wellformed k (ECSubst.substl ts u). Proof using Type. induction ts in u |- *; cbn => //. @@ -305,7 +305,7 @@ Section EEnvFlags. eapply wellformed_csubst => //. Qed. - Lemma wellformed_fix_subst mfix {hast : has_tFix}: + Lemma wellformed_fix_subst mfix {hast : has_tFix}: forallb (isLambda ∘ dbody) mfix -> forallb (EAst.test_def (wellformed (#|mfix| + 0))) mfix -> forallb (wellformed 0) (fix_subst mfix). @@ -319,7 +319,7 @@ Section EEnvFlags. apply/andP; split. apply Nat.ltb_lt. lia. apply IHn. lia. Qed. - Lemma wellformed_cofix_subst mfix {hasco : has_tCoFix}: + Lemma wellformed_cofix_subst mfix {hasco : has_tCoFix}: forallb (EAst.test_def (wellformed (#|mfix| + 0))) mfix -> forallb (wellformed 0) (cofix_subst mfix). Proof using Type. @@ -340,7 +340,7 @@ Section EEnvFlags. rewrite /cunfold_fix. destruct nth_error eqn:heq => //. cbn in cl. move/andP: cl => [/andP[] hastf isfix /andP[] hidx cl]. - have := (nth_error_forallb heq cl) => cld. + have := (nth_error_forallb heq cl) => cld. move=> [=] _ <-. eapply wellformed_substl => //. now eapply wellformed_fix_subst. rewrite fix_subst_length. @@ -356,7 +356,7 @@ Section EEnvFlags. rewrite /cunfold_cofix. destruct nth_error eqn:heq => //. cbn in cl. move/andP: cl => [hastf /andP[] _ cl]. - have := (nth_error_forallb heq cl) => cld. + have := (nth_error_forallb heq cl) => cld. move=> [=] _ <-. eapply wellformed_substl => //. now eapply wellformed_cofix_subst. rewrite cofix_subst_length. @@ -401,7 +401,7 @@ End EEnvFlags. Lemma wellformed_closed_env {efl} {Σ : global_declarations} : wf_glob Σ -> closed_env Σ. Proof. - induction 1; cbn; auto. + induction 1; cbn; auto. apply/andP; split. - unfold test_snd => /=. now eapply wellformed_closed_decl. @@ -426,9 +426,9 @@ Proof. Qed. -Lemma extends_lookup_constructor {efl} {Σ Σ'} : +Lemma extends_lookup_constructor {efl} {Σ Σ'} : wf_glob Σ' -> extends Σ Σ' -> - forall ind c b, lookup_constructor Σ ind c = Some b -> + forall ind c b, lookup_constructor Σ ind c = Some b -> lookup_constructor Σ' ind c = Some b. Proof. intros wf ex ind c b. @@ -437,9 +437,9 @@ Proof. now rewrite (extends_lookup wf ex lookup). Qed. -Lemma extends_constructor_isprop_pars_decl {efl} {Σ Σ'} : +Lemma extends_constructor_isprop_pars_decl {efl} {Σ Σ'} : wf_glob Σ' -> extends Σ Σ' -> - forall ind c b, constructor_isprop_pars_decl Σ ind c = Some b -> + forall ind c b, constructor_isprop_pars_decl Σ ind c = Some b -> constructor_isprop_pars_decl Σ' ind c = Some b. Proof. intros wf ex ind c b. @@ -448,7 +448,7 @@ Proof. now rewrite (extends_lookup_constructor wf ex _ _ _ lookup). Qed. -Lemma extends_is_propositional {efl} {Σ Σ'} : +Lemma extends_is_propositional {efl} {Σ Σ'} : wf_glob Σ' -> extends Σ Σ' -> forall ind b, inductive_isprop_and_pars Σ ind = Some b -> inductive_isprop_and_pars Σ' ind = Some b. Proof. @@ -458,7 +458,7 @@ Proof. now rewrite (extends_lookup wf ex lookup). Qed. -Lemma extends_wellformed {efl} {Σ Σ'} : +Lemma extends_wellformed {efl} {Σ Σ'} : wf_glob Σ' -> extends Σ Σ' -> forall t n, wellformed Σ n t -> wellformed Σ' n t. Proof. @@ -472,7 +472,7 @@ Proof. - move/andP: H0 => [] hn hf. unfold wf_fix. rewrite hn /=. solve_all. Qed. -Lemma extends_wf_global_decl {efl} {Σ Σ'} : +Lemma extends_wf_global_decl {efl} {Σ Σ'} : wf_glob Σ' -> extends Σ Σ' -> forall t, wf_global_decl Σ t -> wf_global_decl Σ' t. Proof. @@ -481,7 +481,7 @@ Proof. now eapply extends_wellformed. Qed. -Lemma lookup_env_wellformed {efl} {Σ kn decl} : wf_glob Σ -> +Lemma lookup_env_wellformed {efl} {Σ kn decl} : wf_glob Σ -> EGlobalEnv.lookup_env Σ kn = Some decl -> wf_global_decl Σ decl. Proof. induction Σ; cbn => //. diff --git a/erasure/theories/EWtAst.v b/erasure/theories/EWtAst.v index 14dc1fc5a..9c18ac957 100644 --- a/erasure/theories/EWtAst.v +++ b/erasure/theories/EWtAst.v @@ -21,14 +21,14 @@ Section WellScoped. Context (Σ : global_context). Definition lookup_constant kn : option constant_body := - decl <- EGlobalEnv.lookup_env Σ kn;; + decl <- EGlobalEnv.lookup_env Σ kn;; match decl with | ConstantDecl decl => Some decl | InductiveDecl mdecl => None end. - + Definition lookup_minductive kn : option mutual_inductive_body := - decl <- EGlobalEnv.lookup_env Σ kn;; + decl <- EGlobalEnv.lookup_env Σ kn;; match decl with | ConstantDecl _ => None | InductiveDecl mdecl => ret mdecl @@ -46,24 +46,24 @@ Section WellScoped. Definition lookup_projection (proj : projection) := '(mdecl, idecl) <- lookup_inductive (fst (fst proj)) ;; - pdecl <- List.nth_error idecl.(ind_projs) (snd proj) ;; + pdecl <- List.nth_error idecl.(ind_projs) (snd proj) ;; ret (mdecl, idecl, pdecl). - + Definition declared_constant id : bool := isSome (lookup_constant id). - + Definition declared_minductive mind := isSome (lookup_minductive mind). - + Definition declared_inductive ind := isSome (lookup_inductive ind). - + Definition declared_constructor kn c := isSome (lookup_constructor kn c). - + Definition declared_projection kn := isSome (lookup_projection kn). - + Equations well_scoped (n : nat) (t : EAst.term) : bool := { | n, tBox => true | n, tRel i := i -> is_true. Module Constructors. Section Constructors. Context {Σ : global_context} {n : nat}. - + Obligation Tactic := idtac. Program Definition tBox : eterm Σ n := tBox. Next Obligation. cbn. exact eq_refl. Defined. - - + + Program Definition tRel (i : nat) (Hi : i < n) : eterm Σ n := tRel i. Next Obligation. cbn; intros. eapply Nat.leb_le, Hi. Defined. - + Lemma andP (a b : bool) : a -> b -> a && b. Proof. destruct a, b; cbn; intros; try exact eq_refl; try discriminate. Defined. @@ -133,9 +133,9 @@ Module Constructors. Next Obligation. cbn; intros. induction l; cbn. exact eq_refl. - apply andP. exact a. exact IHl. + apply andP. exact a. exact IHl. Defined. - + Program Definition tLambda na (b : eterm Σ (S n)) : eterm Σ n := tLambda na b. Next Obligation. intros. exact b. @@ -171,7 +171,7 @@ Module Constructors. Program Definition tConst kn (isdecl : declared_constant Σ kn) : eterm Σ n := tConst kn. Program Definition tConstruct ind k (isdecl : declared_constructor Σ ind k) : eterm Σ n := tConstruct ind k. - + Program Definition tCase ci (c : eterm Σ n) (brs : list (∑ args : list name, eterm Σ (#|args| + n))) (isdecl : declared_inductive Σ ci.1) : eterm Σ n := tCase ci c (map (fun br : ∑ args, eterm Σ (#|args| + n) => (br.π1, proj1_sig br.π2)) brs). @@ -202,7 +202,7 @@ Module Constructors. Next Obligation. cbn; intros. exact mfix.π2. Defined. - + Program Definition tCoFix (mfix : edefs) idx : eterm Σ n := (tCoFix mfix.π1 idx). Next Obligation. cbn; intros; exact mfix.π2. @@ -231,7 +231,7 @@ Module View. | tCoFix mfix idx : t (Constructors.tCoFix mfix idx). Derive Signature for t. - Equations view_term {e} (v : t e) : term := + Equations view_term {e} (v : t e) : term := | tBox => EAst.tBox | tRel i le => EAst.tRel i | tEvar k l => EAst.tEvar k (map eterm_term l) @@ -255,14 +255,14 @@ Module View. Lemma view_size_let_body {na} {b : eterm Σ n} {b' : eterm Σ (S n)} : size b' < size (Constructors.tLetIn na b b'). Proof. cbn. lia. Qed. - + Lemma view_size_lambda {na} {b : eterm Σ (S n)} : size b < size (Constructors.tLambda na b). Proof. cbn. lia. Qed. - + End ViewSizes. - + End View. - + Lemma well_scoped_irr {Σ n t} (ws ws' : well_scoped Σ n t) : ws = ws'. Proof. apply uip. Defined. @@ -379,7 +379,7 @@ Section view. rewrite (well_scoped_irr ws ws'); subst ws' t'. unshelve econstructor. cbn. apply (andb_left (andb_left ws)). - + - change t with (eterm_term (t ⧆ andb_right ws)) in t'. set (prf := andb_right ws) in *. clearbody prf. evar (ws' : well_scoped Σ n t' = true). @@ -414,7 +414,7 @@ Section test_view. Context (Σ : global_context). Import View. - Definition eterm_size : relation (∑ n, eterm Σ n) := + Definition eterm_size : relation (∑ n, eterm Σ n) := MR lt (fun x : ∑ n, eterm Σ n => size x.π2). Instance wf_size : WellFounded eterm_size. @@ -422,7 +422,7 @@ Section test_view. Obligation Tactic := idtac. #[derive(eliminator=no)] - Equations? test_view (n : nat) (t : eterm Σ n) : bool + Equations? test_view (n : nat) (t : eterm Σ n) : bool by wf (n; t) eterm_size := test_view n t with view t := { | tBox => true diff --git a/erasure/theories/Erasure.v b/erasure/theories/Erasure.v index 83c149053..ce41540d3 100644 --- a/erasure/theories/Erasure.v +++ b/erasure/theories/Erasure.v @@ -26,17 +26,17 @@ Obligation Tactic := program_simpl. Import EWcbvEval. -Axiom assume_welltyped_template_program_expansion : +Axiom assume_welltyped_template_program_expansion : forall p (wtp : ∥ wt_template_program_env p ∥), let p' := EtaExpand.eta_expand_program p in ∥ wt_template_program p' ∥ /\ EtaExpand.expanded_program p'. -Axiom assume_preservation_template_program_env_expansion : +Axiom assume_preservation_template_program_env_expansion : forall p (wtp : ∥ wt_template_program_env p ∥) v, eval_template_program_env p v -> ∥ eval_template_program (EtaExpand.eta_expand_program p) (EtaExpand.eta_expand p.1 [] v) ∥. -Program Definition eta_expand : Transform.t template_program_env template_program Ast.term Ast.term +Program Definition eta_expand : Transform.t template_program_env template_program Ast.term Ast.term eval_template_program_env eval_template_program := {| name := "eta expand cstrs and fixpoints"; pre := fun p => ∥ wt_template_program_env p ∥ ; @@ -47,15 +47,15 @@ Next Obligation. destruct p. now apply assume_welltyped_template_program_expansion. Qed. Next Obligation. - red. intros p v [wt] ev. + red. intros p v [wt] ev. apply assume_preservation_template_program_env_expansion in ev as [ev']; eauto. Qed. Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : - Transform.t TemplateProgram.template_program EProgram.eprogram + Transform.t TemplateProgram.template_program EProgram.eprogram Ast.term EAst.term TemplateProgram.eval_template_program - (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := + (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := (* Build an efficient lookup map for the following eta-expansion phase *) build_template_program_env ▷ (* Eta-expand constructors and fixpoint *) @@ -66,12 +66,12 @@ Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellf pcuic_expand_lets_transform ▷ (* Erasure of proofs terms in Prop and types *) erase_transform ▷ - (* Simulation of the guarded fixpoint rules with a single unguarded one: - the only "stuck" fixpoints remaining are unapplied. + (* Simulation of the guarded fixpoint rules with a single unguarded one: + the only "stuck" fixpoints remaining are unapplied. This translation is a noop on terms and environments. *) guarded_to_unguarded_fix (wcon := eq_refl) eq_refl ▷ (* Remove all constructor parameters *) - remove_params_optimization (wcon := eq_refl) ▷ + remove_params_optimization (wcon := eq_refl) ▷ (* Rebuild the efficient lookup table *) rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ (* Remove all cases / projections on propositional content *) @@ -86,9 +86,9 @@ Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellf (* First-order constructor representation *) constructors_as_blocks_transformation efl (has_app := eq_refl) (has_pars := eq_refl) (has_cstrblocks := eq_refl). -(* At the end of erasure we get a well-formed program (well-scoped globally and localy), without +(* At the end of erasure we get a well-formed program (well-scoped globally and localy), without parameters in inductive declarations. The constructor applications are also transformed to a first-order - "block" application, of the right length, and the evaluation relation does not need to consider guarded + "block" application, of the right length, and the evaluation relation does not need to consider guarded fixpoints or case analyses on propositional content. All fixpoint bodies start with a lambda as well. Finally, projections are inlined to cases, so no `tProj` remains. *) @@ -96,19 +96,19 @@ Import EGlobalEnv EWellformed. Next Obligation. destruct H. split => //. sq. - now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs. + now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs. Qed. Definition run_erase_program {guard : abstract_guard_impl} := run erasure_pipeline. -Program Definition erasure_pipeline_fast {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) := +Program Definition erasure_pipeline_fast {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) := build_template_program_env ▷ eta_expand ▷ template_to_pcuic_transform ▷ pcuic_expand_lets_transform ▷ - erase_transform ▷ + erase_transform ▷ guarded_to_unguarded_fix (wcon := eq_refl) eq_refl ▷ - remove_params_fast_optimization (wcon := eq_refl) _ ▷ + remove_params_fast_optimization (wcon := eq_refl) _ ▷ rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ @@ -117,14 +117,14 @@ Program Definition erasure_pipeline_fast {guard : abstract_guard_impl} (efl := E rebuild_wf_env_transform (efl := efl) true ▷ constructors_as_blocks_transformation efl (has_app := eq_refl) (has_pars := eq_refl) (has_cstrblocks := eq_refl). Next Obligation. - destruct H; split => //. now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs. + destruct H; split => //. now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs. Qed. Definition run_erase_program_fast {guard : abstract_guard_impl} := run erasure_pipeline_fast. Local Open Scope string_scope. -Axiom fake_guard_impl_properties : +Axiom fake_guard_impl_properties : forall (fix_cofix: PCUICTyping.FixCoFix) (Σ: PCUICAst.PCUICEnvironment.global_env_ext) (Γ: PCUICAst.PCUICEnvironment.context) @@ -136,9 +136,9 @@ Global Program Instance fake_guard_impl : abstract_guard_impl := {| guard_impl := fake_guard_impl |}. Next Obligation. apply fake_guard_impl_properties. Qed. -(** This uses the retyping-based erasure and assumes that the global environment and term - are welltyped (for speed). As such this should only be used for testing, or when we know that - the environment is wellformed and the term well-typed (e.g. when it comes directly from a +(** This uses the retyping-based erasure and assumes that the global environment and term + are welltyped (for speed). As such this should only be used for testing, or when we know that + the environment is wellformed and the term well-typed (e.g. when it comes directly from a Coq definition). *) diff --git a/erasure/theories/ErasureCorrectness.v b/erasure/theories/ErasureCorrectness.v index 97e177fc5..e4dda0f6e 100644 --- a/erasure/theories/ErasureCorrectness.v +++ b/erasure/theories/ErasureCorrectness.v @@ -42,7 +42,7 @@ Import ssrbool. Lemma erases_correct (wfl := default_wcbv_flags) Σ t T t' v Σ' : wf_ext Σ -> Σ;;; [] |- t : T -> - Σ;;; [] |- t ⇝ℇ t' -> + Σ;;; [] |- t ⇝ℇ t' -> erases_deps Σ Σ' t' -> Σ |-p t ▷ v -> exists v', Σ;;; [] |- v ⇝ℇ v' /\ ∥ Σ' ⊢ t' ▷ v' ∥. @@ -65,7 +65,7 @@ Proof. eapply PCUICConversion.ws_cumul_pb_Prod_Prod_inv in e0 as [? e1 e2]. eapply type_Cumul_alt. eassumption. now exists x2. symmetry in e1. - eapply ws_cumul_pb_forget in e1. + eapply ws_cumul_pb_forget in e1. now eapply conv_cumul. } assert (eqs := type_closed_subst b wfΣ X0). invs Hvf'. @@ -100,7 +100,7 @@ Proof. - assert (Hty' := Hty). assert (Σ |-p tLetIn na b0 t b1 ▷ res) by eauto. eapply inversion_LetIn in Hty' as (? & ? & ? & ? & ? & ?); auto. - invs He. + invs He. + depelim Hed. eapply IHeval1 in H6 as (vt1' & Hvt2' & [He_vt1']); eauto. assert (Hc : conv_context cumulAlgo_gen Σ ([],, vdef na b0 t) [vdef na b0' t]). { @@ -173,7 +173,7 @@ Proof. rename ci into ind. pose proof d as d'. eapply declared_constructor_inductive in d'. edestruct (declared_inductive_inj d' di); subst. clear d'. - + assert (Σ ;;; [] |- mkApps (tConstruct ind c u) args : mkApps (tInd ind (puinst p)) (pparams p ++ indices)). eapply subject_reduction_eval; eauto. assert (Hcstr := X0). @@ -195,12 +195,12 @@ Proof. rewrite -mkApps_app in X1. eapply tConstruct_no_Type in X1; auto. - + eapply H6 in X1 as []; eauto. 2: split; auto; exists []; now destruct Σ. destruct (ind_ctors idecl) eqn:hctors. { cbn in *. depelim brs_ty. rewrite nth_error_nil // in Hnth. } - depelim brs_ty. cbn in H1. + depelim brs_ty. cbn in H1. destruct l; cbn in *; try lia. depelim brs_ty. depelim X0. depelim X0. destruct p1. @@ -249,7 +249,7 @@ Proof. intros ? ? ? % repeat_spec. subst. constructor. now eapply isErasable_Proof. } - 2:{ + 2:{ exists x2. split; eauto. constructor. eapply eval_iota_sing => //. pose proof (Ee.eval_to_value _ _ He_v'). eapply value_app_inv in X0. subst. eassumption. @@ -267,7 +267,7 @@ Proof. apply (declared_constructor_assumption_context d). } rewrite ECSubst.substl_subst //. { eapply forallb_repeat. econstructor. } - replace (ind_npars mdecl + #|bcontext br| - ind_npars mdecl) + replace (ind_npars mdecl + #|bcontext br| - ind_npars mdecl) with #|bcontext br| in H11 by lia. eauto. } depelim H4. @@ -290,19 +290,19 @@ Proof. etransitivity. constructor. constructor. eauto. - { rewrite e0 /cstr_arity e2 e1 //. } - unfold iota_red. reflexivity. - + { rewrite e0 /cstr_arity e2 e1 //. } + unfold iota_red. reflexivity. + { assert (expand_lets (inst_case_branch_context p br) (br.(PCUICAst.bbody)) = br.(PCUICAst.bbody)) as ->. { unshelve edestruct @on_declared_constructor as (? & ? & ? & []). 8: exact d. all: eauto. pattern br. eapply All_nth_error. 2: eauto. eapply (expand_lets_erasure d wf_brs). solve_all. - } - eapply erases_subst0; eauto. + } + eapply erases_subst0; eauto. all: try rewrite case_branch_type_fst PCUICCasesContexts.inst_case_branch_context_eq; eauto. - rewrite app_context_nil_l. + rewrite app_context_nil_l. erewrite <-PCUICCasesContexts.inst_case_branch_context_eq; eauto. 1:{ eapply (subslet_cstr_branch_context (u:=u)); tea. - rewrite lenppars firstn_app_left // in s0. exact s0. @@ -312,17 +312,17 @@ Proof. - red in wf_brs. eapply Forall2_All2 in wf_brs. eapply All2_nth_error in wf_brs; tea. - rewrite -eq_npars. exact s1. } - eapply All2_rev. eapply All2_skipn. + eapply All2_rev. eapply All2_skipn. eapply Forall2_All2 in H3. eapply All2_impl. exact H3. intros. eauto. } - + eapply nth_error_forall in H5; [|now eauto]. eapply erases_deps_subst; eauto. eapply All_rev. eapply erases_deps_eval in He_v'; [|now eauto]. eapply erases_deps_mkApps_inv in He_v' as (? & ?). now eapply All_skipn, Forall_All. - + invs H2. -- exists x2. split; eauto. constructor. econstructor. eauto. eauto. 2:eauto. @@ -333,13 +333,13 @@ Proof. { move/eval_closed: H; tea. move/(_ (subject_closed scrut_ty)). now rewrite closedn_mkApps /=. } - solve_all. eapply (erases_closed _ []); tea. } + solve_all. eapply (erases_closed _ []); tea. } rewrite -eq_npars. eapply isPropositional_propositional_cstr; eauto. rewrite -(Forall2_length H3) /= e1 //. rewrite skipn_length -(Forall2_length H3) -e6 /= map_length. rewrite (All2_length a). - replace #|cstr_branch_context ind mdecl cdecl| + replace #|cstr_branch_context ind mdecl cdecl| with (context_assumptions (cstr_branch_context ind mdecl cdecl)). 2:{ eapply assumption_context_assumptions. eapply (assumption_context_cstr_branch_context d). } @@ -375,7 +375,7 @@ Proof. assert (expand_lets (inst_case_branch_context p br) (br.(PCUICAst.bbody)) = br.(PCUICAst.bbody)) as ->. { unshelve edestruct @on_declared_constructor as (? & ? & ? & []). 8: exact d. all: eauto. pattern br. - eapply All_nth_error. + eapply All_nth_error. eapply expand_lets_erasure; eauto. 2: instantiate (1 := 0); cbn; eassumption. rewrite hctors. constructor; auto. constructor. } @@ -412,14 +412,14 @@ Proof. apply value_app_inv in X0; subst x0. apply He_v'. now rewrite -eq_npars. - + cbn in *. rewrite ECSubst.substl_subst. { eapply forallb_repeat. econstructor. } rewrite rev_repeat in H10. - + enough (#|skipn (ind_npars mdecl) args| = #|n|) as <- by eauto. edestruct invert_Case_Construct as (? & ? & ? & ?). { econstructor. eauto. } @@ -429,7 +429,7 @@ Proof. rewrite eq_npars. rewrite List.skipn_length e0 /cstr_arity -e1 e2. replace (ci_npar ind + context_assumptions (bcontext br) - ci_npar ind) with (context_assumptions (bcontext br)) by lia. - subst n. rewrite map_length. + subst n. rewrite map_length. rewrite assumption_context_assumptions //. eapply assumption_context_compare_decls. symmetry; tea. eapply (assumption_context_cstr_branch_context d). @@ -461,7 +461,7 @@ Proof. 2:{ exact d. } 2: split; auto; now exists []; destruct Σ. destruct d0 as (? & ? & ?). - + econstructor. eapply Is_type_eval; eauto. eapply nth_error_all. @@ -479,7 +479,7 @@ Proof. assert (lenx5 := Forall2_length H4). eapply Forall2_nth_error_Some in H4 as (? & ? & ?); eauto. assert (Σ ;;; [] |- mkApps (tConstruct p.(proj_ind) 0 u) args : mkApps (tInd p.(proj_ind) x) x3). - eapply subject_reduction_eval; eauto. + eapply subject_reduction_eval; eauto. eapply inversion_mkApps in X as (? & ? & ?); eauto. eapply Prelim.typing_spine_inv in t1 as []; eauto. eapply IHeval2 in H3 as (? & ? & [?]); eauto. @@ -517,7 +517,7 @@ Proof. eapply erases_deps_mkApps_inv in Hty_vc' as (? & ?). now eapply nth_error_forall in H1; eauto. + exists EAst.tBox. split. econstructor. - eapply Is_type_eval. 3: eassumption. all:eauto. constructor. econstructor. eauto. + eapply Is_type_eval. 3: eassumption. all:eauto. constructor. econstructor. eauto. - assert (Hty' := Hty). assert (Hunf := H). assert (Hcon := H0). @@ -531,7 +531,7 @@ Proof. destruct Hfix as (? & ? & ? & ? & ? & ? & e1). unfold cunfold_fix in e. rewrite e2 in e. invs e. depelim He; first last. - + + exists EAst.tBox. split; [|now constructor; constructor]. econstructor. eapply Is_type_eval. 3:eapply X. eauto. @@ -588,7 +588,7 @@ Proof. eapply IHeval3 in H2 as (? & ? & [?]); cbn; eauto; cycle 1. { eapply subject_reduction. eauto. exact Hty. etransitivity. - eapply PCUICReduction.red_app. eapply wcbeval_red; eauto. + eapply PCUICReduction.red_app. eapply wcbeval_red; eauto. eapply wcbeval_red; eauto. rewrite <- !mkApps_snoc. eapply PCUICReduction.red1_red. @@ -599,7 +599,7 @@ Proof. pose proof (eval_to_value _ _ _ e3) as vfix. eapply PCUICWcbvEval.stuck_fix_value_args in vfix; eauto. 2:{ rewrite /cunfold_fix e2 //. } - simpl in vfix. + simpl in vfix. subst. unfold is_constructor. rewrite nth_error_snoc. lia. assert(Σ ;;; [] |- mkApps (tFix mfix idx) (argsv ++ [av]) : subst [av] 0 x1). @@ -613,7 +613,7 @@ Proof. eapply value_whnf; eauto. eapply eval_closed; eauto. now eapply subject_closed in t0. eapply eval_to_value; eauto. } - + { constructor. - eapply erases_deps_eval in ev_stuck; [|now eauto]. eapply erases_deps_mkApps_inv in ev_stuck as (? & ?). @@ -643,7 +643,7 @@ Proof. destruct b as [eqb eqrar isl isl' e]. eapply erases_closed in e. simpl in e. rewrite <- H. - unfold EAst.test_def. + unfold EAst.test_def. simpl in e. rewrite fix_context_length in e. now rewrite Nat.add_0_r. @@ -653,7 +653,7 @@ Proof. eauto with pcuic. now eapply subject_closed in Ht. ++ auto. - + -- cbn. destruct a2 as [eqb eqrar isl isl' e5]. eapply (erases_subst Σ [] (fix_context mfix) [] dbody (fix_subst mfix)) in e5; cbn; eauto. ++ eapply subslet_fix_subst. now eapply wf_ext_wf. all: eassumption. @@ -673,7 +673,7 @@ Proof. ++ econstructor. eapply Is_type_eval. 3:eauto. all:eauto. rewrite mkApps_app. - eapply eval_fix; eauto. + eapply eval_fix; eauto. 1-2:eapply value_final, eval_to_value; eauto. rewrite /cunfold_fix e2 //. congruence. ++ constructor. eapply Ee.eval_box; [|now eauto]. @@ -734,7 +734,7 @@ Proof. ++ eauto. ++ unfold EGlobalEnv.cunfold_fix. now rewrite e0. ++ eapply Forall2_length in H5. noconf e. lia. - + -- exists E.tBox. apply eval_to_mkApps_tBox_inv in H3 as ?; subst. split; [|now constructor; eauto using @Ee.eval]. @@ -757,14 +757,14 @@ Proof. assert (htcof : Σ ;;; [] |- tCase ip p (mkApps (tCoFix mfix idx) args) brs : T). { eapply subject_reduction; eauto. eapply PCUICReduction.red_case_c. eapply wcbeval_red in H; eauto. } - assert (hredcasecof : + assert (hredcasecof : PCUICReduction.red Σ [] (tCase ip p (mkApps (tCoFix mfix idx) args) brs) (tCase ip p (mkApps fn args) brs)). { constructor; eapply PCUICReduction.red_cofix_case. move: e. rewrite closed_unfold_cofix_cunfold_eq; eauto. } assert (htcasefn : Σ ;;; [] |- tCase ip p (mkApps fn args) brs : T). { eapply subject_reduction; eauto. } - assert (hredcasediscrcof : + assert (hredcasediscrcof : PCUICReduction.red Σ [] (tCase ip p discr brs) res). { etransitivity. eapply PCUICReduction.red_case_c; tea. eapply wcbeval_red in H. tea. eauto. @@ -774,7 +774,7 @@ Proof. specialize (IHeval1 _ t0'). specialize (IHeval2 _ htunfcof). eapply inversion_CoFix in t; destruct_sigma t; auto. - eapply PCUICSpine.typing_spine_strengthen in t0; eauto. + eapply PCUICSpine.typing_spine_strengthen in t0; eauto. 2:{ now eapply nth_error_all in a; tea. } invs He. * edestruct IHeval1 as (? & ? & ?); eauto. now depelim Hed. @@ -783,13 +783,13 @@ Proof. rename H0 into decli'. rename H1 into decli''. rename H2 into er. rename H3 into H0. eapply erases_mkApps_inv in H8; eauto. destruct H8 as [He|He]; destruct_sigma He. - -- destruct He as (? & ? & ? & ? & ? & ? & ? & ?). subst. + -- destruct He as (? & ? & ? & ? & ? & ? & ? & ?). subst. destruct H9. edestruct IHeval2 as (? & ? & [?]). { destruct H2 as [i1]. constructor; eauto. rewrite mkApps_app. eapply erases_mkApps. instantiate(1:=EAst.tBox). - constructor. + constructor. eapply isErasable_Proof. eapply tCoFix_no_Type in i1; auto. pose proof i1 as X0'. destruct X0' as [tyapp [u [Htyapp Hu]]]. @@ -812,7 +812,7 @@ Proof. depelim hcof. { eapply All2_nth_error_Some in X0 as X'; tea. destruct X' as [t' [nth' [bn [rar eb]]]]. - specialize (IHeval2 (E.tCase (ip, ci_npar ip) + specialize (IHeval2 (E.tCase (ip, ci_npar ip) (E.mkApps (ELiftSubst.subst0 (EGlobalEnv.cofix_subst mfix') (E.dbody t')) L') brs')). forward IHeval2. econstructor; eauto. @@ -862,7 +862,7 @@ Proof. { econstructor; eauto. } exists v'. split => //. split. eapply eval_case_eval_inv_discr; tea. } - + * depelim Hed. exists E.tBox. split; repeat constructor; auto. assert (PCUICReduction.red Σ [] (tCase ip p discr brs) res). @@ -976,8 +976,8 @@ Proof. { econstructor; eauto. } exists v'. split => //. split. eapply eval_proj_eval_inv_discr; tea. } - } - + } + * depelim Hed. exists E.tBox. split; repeat constructor; auto. assert (PCUICReduction.red Σ [] (tProj p discr) res). @@ -988,7 +988,7 @@ Proof. constructor. eapply PCUICReduction.red_cofix_proj. move: e. rewrite closed_unfold_cofix_cunfold_eq //. intros e; exact e. now eapply isErasable_red. - + * eauto. - pose (Hty' := Hty). @@ -1136,7 +1136,7 @@ Proof. induction er; intros wf. - constructor. - cbn. destruct cb' as [[]]. - cbn in *. depelim wf. destruct o. + cbn in *. depelim wf. destruct o. rewrite [forallb _ _](IHer wf) andb_true_r. red in H. destruct cb as [ty []]; cbn in *. unshelve eapply PCUICClosedTyp.subject_closed in on_global_decl_d. cbn. split; auto. @@ -1146,7 +1146,7 @@ Proof. cbn. apply IHer, wf. Qed. -Lemma erases_global_decls_fresh univs retro {Σ : global_declarations} kn Σ' : fresh_global kn Σ -> +Lemma erases_global_decls_fresh univs retro {Σ : global_declarations} kn Σ' : fresh_global kn Σ -> erases_global_decls univs retro Σ Σ' -> EGlobalEnv.fresh_global kn Σ'. Proof. induction 2; constructor; eauto; now depelim H. @@ -1157,7 +1157,7 @@ Import EWellformed. Lemma erases_mutual_inductive_body_wf (efl := all_env_flags) {Σ univs retro Σ' kn mib mib'} : erases_mutual_inductive_body mib mib' -> let udecl := PCUICLookup.universes_decl_of_decl (InductiveDecl mib) in - on_global_decl cumulSpec0 (PCUICEnvTyping.lift_typing typing) + on_global_decl cumulSpec0 (PCUICEnvTyping.lift_typing typing) ({| universes := univs; declarations := Σ; retroknowledge := retro |}, udecl) kn (InductiveDecl mib) -> wf_global_decl Σ' (E.InductiveDecl mib'). @@ -1177,7 +1177,7 @@ Proof. destruct (ind_ctors hd) as [|ctor []] eqn:hctors => //. depelim H. rewrite H1. depelim H0. cbn. destruct X. - destruct H. rewrite -H. + destruct H. rewrite -H. rewrite H3 in on_projs_all. cbn in on_projs_all. eapply Forall2_length in Hprojs. rewrite Hprojs in on_projs_all. rewrite on_projs_all. @@ -1185,7 +1185,7 @@ Proof. rewrite hctors in X. red in X. depelim X. destruct o. rewrite cstr_args_length. apply eqb_refl. -Qed. +Qed. Lemma erases_global_wf_glob {Σ : global_env} Σ' : wf Σ -> erases_global Σ Σ' -> @wf_glob all_env_flags Σ'. Proof. @@ -1194,7 +1194,7 @@ Proof. move: wf. red in er; cbn in er. induction er; intros wf. - constructor. - - cbn. depelim wf. destruct o. + - cbn. depelim wf. destruct o. constructor; eauto. 2:eapply erases_global_decls_fresh; tea. cbn. red in H. @@ -1208,8 +1208,8 @@ Proof. forward H0. now eexists. specialize (H0 H Σ'). eapply H0. eapply erases_global_all_deps; tea. split => //. - destruct (E.cst_body cb') => //. - - depelim wf. destruct o. + destruct (E.cst_body cb') => //. + - depelim wf. destruct o. constructor; eauto. now eapply erases_mutual_inductive_body_wf. now eapply erases_global_decls_fresh; tea. @@ -1227,7 +1227,7 @@ Proof. now eapply cstr_args_length in o. Qed. -From MetaCoq.PCUIC Require Import PCUICEtaExpand. +From MetaCoq.PCUIC Require Import PCUICEtaExpand. From MetaCoq.Erasure Require Import EDeps EEtaExpandedFix. Local Hint Constructors expanded : core. @@ -1243,9 +1243,9 @@ Proof. induction exp using PCUICEtaExpand.expanded_ind; cbn. all:try solve [intros Γ0 v etaΣ hv; depelim hv; try depelim etaΣ; constructor; solve_all]. - move=> Γ0 etaΣ v /erases_mkApps_inv; intros [(?&?&?&?&?&?&?&?)|(?&?&?&?&?)]; subst. - * constructor => //. + * constructor => //. eapply EDeps.erases_deps_mkApps_inv in v as []. - repeat All_Forall.toAll. eapply All_app in H1 as []. + repeat All_Forall.toAll. eapply All_app in H1 as []. solve_all. * eapply EDeps.erases_deps_mkApps_inv in v as []. depelim H4; simp_eta => //. @@ -1263,7 +1263,7 @@ Proof. constructor => //. clear -H H3. destruct H3; cbn in *; congruence. solve_all. - - intros Γ0 v etaΣ hv; depelim hv; try constructor. + - intros Γ0 v etaΣ hv; depelim hv; try constructor. depelim etaΣ. eauto. depelim etaΣ. @@ -1272,7 +1272,7 @@ Proof. - intros Γ0 v etaΣ. move=> /erases_mkApps_inv; intros [(?&?&?&?&_&?&?&?)|(?&?&?&?&?)]; subst. * eapply erases_deps_mkApps_inv in etaΣ as []. - constructor => //. + constructor => //. eapply Forall_All in H2. eapply Forall2_All2 in H8. eapply All_app in H2 as []. solve_all. * eapply erases_deps_mkApps_inv in etaΣ as []. @@ -1303,7 +1303,7 @@ Proof. destruct cdecl'. eapply EEtaExpandedFix.expanded_tConstruct_app; tea. ++ cbn. rewrite -(Forall2_length H5). - destruct (PCUICGlobalEnv.declared_constructor_inj H H4) as [? []]. subst idecl0 mind cdecl0. + destruct (PCUICGlobalEnv.declared_constructor_inj H H4) as [? []]. subst idecl0 mind cdecl0. rewrite (declared_constructor_arity H) in H0. destruct H7. rewrite -H10. destruct H8 as [? _]. diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 753a19a13..e58068bb6 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -8,7 +8,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrimitive PCUICWeakeningConv PCUICWeakeningTyp PCUICContextConversionTyp PCUICTyping PCUICGlobalEnv PCUICInversion PCUICGeneration PCUICConfluence PCUICConversion PCUICUnivSubstitutionTyp PCUICCumulativity PCUICSR PCUICSafeLemmata PCUICValidity PCUICPrincipality PCUICElimination PCUICOnFreeVars PCUICWellScopedCumulativity PCUICSN PCUICEtaExpand. - + From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnv PCUICSafeReduce PCUICSafeRetyping PCUICRetypingEnvIrrelevance. From MetaCoq.Erasure Require Import EAstUtils EArities Extract Prelim EDeps ErasureProperties ErasureCorrectness. @@ -24,12 +24,12 @@ Implicit Types (cf : checker_flags). Notation alpha_eq := (All2 (PCUICEquality.compare_decls eq eq)). -Ltac sq := +Ltac sq := repeat match goal with | H : ∥ _ ∥ |- _ => destruct H as [H] end; try eapply sq. -Lemma wf_local_rel_alpha_eq_end {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ Δ'} : +Lemma wf_local_rel_alpha_eq_end {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ Δ'} : wf_local Σ Γ -> alpha_eq Δ Δ' -> wf_local_rel Σ Γ Δ -> wf_local_rel Σ Γ Δ'. @@ -43,7 +43,7 @@ Qed. Section OnInductives. Context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}. - + Lemma on_minductive_wf_params_weaken {ind mdecl Γ} {u} : declared_minductive Σ.1 ind mdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> @@ -54,10 +54,10 @@ Section OnInductives. eapply weaken_wf_local; tea. eapply PCUICArities.on_minductive_wf_params; tea. Qed. - + Context {mdecl ind idecl} (decli : declared_inductive Σ ind mdecl idecl). - + Lemma on_minductive_wf_params_indices_inst_weaken {Γ} (u : Instance.t) : consistent_instance_ext Σ (ind_universes mdecl) u -> wf_local Σ Γ -> @@ -76,25 +76,25 @@ Local Existing Instance extraction_checker_flags. Hint Resolve wf_ext_wf : core. *) Ltac specialize_Σ wfΣ := - repeat match goal with | h : _ |- _ => specialize (h _ wfΣ) end. + repeat match goal with | h : _ |- _ => specialize (h _ wfΣ) end. Section fix_sigma. Context {cf : checker_flags} {nor : normalizing_flags}. Context (X_type : abstract_env_impl). Context (X : X_type.π2.π1). - - Local Definition heΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : + + Local Definition heΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : ∥ wf_ext Σ ∥ := abstract_env_ext_wf _ wfΣ. Local Definition HΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : - ∥ wf Σ ∥ := abstract_env_ext_sq_wf _ _ _ wfΣ. + ∥ wf Σ ∥ := abstract_env_ext_sq_wf _ _ _ wfΣ. - Definition term_rel : Relation_Definitions.relation + Definition term_rel : Relation_Definitions.relation (∑ Γ t, forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) := fun '(Γ2; B; H) '(Γ1; t1; H2) => - forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> + forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥∑ na A, red Σ Γ1 t1 (tProd na A B) × (Γ1,, vass na A) = Γ2∥. - + Definition cod B t := match t with tProd _ _ B' => B = B' | _ => False end. Lemma wf_cod : WellFounded cod. @@ -112,21 +112,21 @@ Section fix_sigma. induction 1. intros. eapply H0; eauto. Qed. - Ltac sq' := + Ltac sq' := repeat match goal with | H : ∥ _ ∥ |- _ => destruct H; try clear H end; try eapply sq. - + Definition wf_reduction_aux : WellFounded term_rel. Proof. intros (Γ & s & H). sq'. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ']]. - pose proof (abstract_env_ext_wf _ wfΣ') as wf. sq. - set (H' := H _ wfΣ'). + destruct (abstract_env_ext_exists X) as [[Σ wfΣ']]. + pose proof (abstract_env_ext_wf _ wfΣ') as wf. sq. + set (H' := H _ wfΣ'). induction (normalisation Σ _ Γ s H') as [s _ IH]. cbn in IH. induction (wf_cod' s) as [s _ IH_sub] in Γ, H , H', IH |- *. econstructor. - intros (Γ' & B & ?) [(na & A & ? & ?)]; eauto. subst. + intros (Γ' & B & ?) [(na & A & ? & ?)]; eauto. subst. eapply Relation_Properties.clos_rt_rtn1 in r. inversion r. + subst. eapply IH_sub. econstructor. cbn. reflexivity. intros. eapply IH. @@ -147,19 +147,19 @@ Section fix_sigma. * constructor. do 2 eexists. now split. Unshelve. - intros. destruct H' as []. - rewrite <- (abstract_env_ext_irr _ H2) in X0; eauto. - rewrite <- (abstract_env_ext_irr _ H2) in wf; eauto. + rewrite <- (abstract_env_ext_irr _ H2) in X0; eauto. + rewrite <- (abstract_env_ext_irr _ H2) in wf; eauto. eapply inversion_Prod in X0 as (? & ? & ? & ? & ?) ; auto. eapply cored_red in H0 as []. econstructor. econstructor. econstructor. eauto. - 2:reflexivity. econstructor; pcuic. - rewrite <- (abstract_env_ext_irr _ H2) in X0; eauto. + 2:reflexivity. econstructor; pcuic. + rewrite <- (abstract_env_ext_irr _ H2) in X0; eauto. eapply subject_reduction; eauto. - - intros. rewrite <- (abstract_env_ext_irr _ H0) in wf; eauto. - rewrite <- (abstract_env_ext_irr _ H0) in X0; eauto. - rewrite <- (abstract_env_ext_irr _ H0) in r; eauto. + - intros. rewrite <- (abstract_env_ext_irr _ H0) in wf; eauto. + rewrite <- (abstract_env_ext_irr _ H0) in X0; eauto. + rewrite <- (abstract_env_ext_irr _ H0) in r; eauto. eapply red_welltyped; sq. - 3:eapply Relation_Properties.clos_rtn1_rt in r; eassumption. + 3:eapply Relation_Properties.clos_rtn1_rt in r; eassumption. all:eauto. Defined. @@ -168,17 +168,17 @@ Section fix_sigma. refine (Wf.Acc_intro_generator 1000 _). exact wf_reduction_aux. Defined. - + Opaque wf_reduction. - + #[tactic="idtac"] - Equations? is_arity Γ (HΓ : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥wf_local Σ Γ∥) T + Equations? is_arity Γ (HΓ : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥wf_local Σ Γ∥) T (HT : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ T) : bool - by wf ((Γ;T;HT) : (∑ Γ t, forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t)) term_rel := + by wf ((Γ;T;HT) : (∑ Γ t, forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t)) term_rel := { is_arity Γ HΓ T HT with inspect (@reduce_to_sort _ _ X_type X Γ T HT) => { | exist (Checked_comp H) rsort => true ; - | exist (TypeError_comp _) rsort with + | exist (TypeError_comp _) rsort with inspect (@reduce_to_prod _ _ X_type X Γ T HT) => { | exist (Checked_comp (na; A; B; H)) rprod := is_arity (Γ,, vass na A) _ B _ | exist (TypeError_comp e) rprod => false } } @@ -186,16 +186,16 @@ Section fix_sigma. Proof. - clear rprod is_arity rsort a0. intros Σ' wfΣ'; specialize (H Σ' wfΣ'). - repeat specialize_Σ wfΣ'. + repeat specialize_Σ wfΣ'. destruct HT as [s HT]. pose proof (abstract_env_ext_wf _ wfΣ') as [wf]. - sq. + sq. eapply subject_reduction_closed in HT; tea. eapply inversion_Prod in HT as [? [? [? []]]]. now eapply typing_wf_local in t1. pcuic. pcuic. - clear rprod is_arity rsort a0. intros Σ' wfΣ'; specialize (H Σ' wfΣ'). - repeat specialize_Σ wfΣ'. + repeat specialize_Σ wfΣ'. destruct HT as [s HT]. pose proof (abstract_env_ext_wf _ wfΣ') as [wf]. sq. @@ -205,7 +205,7 @@ Section fix_sigma. - cbn. clear rsort is_arity rprod. intros Σ' wfΣ'; specialize (H Σ' wfΣ'). pose proof (abstract_env_ext_wf _ wfΣ') as [wf]. - repeat specialize_Σ wfΣ'. + repeat specialize_Σ wfΣ'. destruct HT as [s HT]. sq. eapply subject_reduction_closed in HT; tea. 2:pcuic. @@ -213,20 +213,20 @@ Section fix_sigma. exists na, A. split => //. eapply H. Defined. - - Lemma is_arityP Γ (HΓ : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥wf_local Σ Γ∥) T + + Lemma is_arityP Γ (HΓ : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥wf_local Σ Γ∥) T (HT : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ T) : - reflect (forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> + reflect (forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> Is_conv_to_Arity Σ Γ T) (is_arity Γ HΓ T HT). Proof. funelim (is_arity Γ HΓ T HT). - constructor. - destruct H as [s Hs]. clear H0 rsort. + destruct H as [s Hs]. clear H0 rsort. pose proof (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize (Hs _ wfΣ) as [Hs]. + specialize (Hs _ wfΣ) as [Hs]. intros. rewrite (abstract_env_ext_irr _ H wfΣ). exists (tSort s); split => //. - - clear H0 H1. + - clear H0 H1. destruct X0; constructor; clear rprod rsort. * red. pose proof (abstract_env_ext_exists X) as [[Σ wfΣ]]. @@ -237,7 +237,7 @@ Section fix_sigma. etransitivity; tea. now eapply closed_red_prod_codom. * pose proof (abstract_env_ext_exists X) as [[Σ wfΣ]]. pose proof (abstract_env_ext_wf X wfΣ) as [wfΣ']. - specialize_Σ wfΣ. sq. + specialize_Σ wfΣ. sq. intros [T' [[HT'] isa]]; eauto. destruct (PCUICContextConversion.closed_red_confluence H HT') as (? & ? & ?); eauto. eapply invert_red_prod in c as (? & ? & []); eauto. subst. @@ -248,18 +248,18 @@ Section fix_sigma. now cbn in isa. - constructor. clear H H0. pose proof (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (abstract_env_ext_wf X wfΣ) as [wfΣ']. + pose proof (abstract_env_ext_wf X wfΣ) as [wfΣ']. symmetry in rprod. symmetry in rsort. intros isc. specialize_Σ wfΣ. eapply Is_conv_to_Arity_inv in isc as []. * destruct H as [na [A [B [Hr]]]]. - apply e. exists na, A, B. + apply e. exists na, A, B. intros ? H. now rewrite (abstract_env_ext_irr _ H wfΣ). * destruct H as [u [Hu]]. - apply a0. exists u. + apply a0. exists u. intros ? H. now rewrite (abstract_env_ext_irr _ H wfΣ). Qed. - + End fix_sigma. Opaque wf_reduction_aux. @@ -277,20 +277,20 @@ Opaque is_arity type_of_typing. Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. -Equations inspect_bool (b : bool) : { b } + { ~~ b } := +Equations inspect_bool (b : bool) : { b } + { ~~ b } := inspect_bool true := left eq_refl; inspect_bool false := right eq_refl. #[tactic="idtac"] -Equations? is_erasableb X_type X (Γ : context) (T : PCUICAst.term) +Equations? is_erasableb X_type X (Γ : context) (T : PCUICAst.term) (wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ T) : bool := is_erasableb X_type X Γ t wt with @type_of_typing extraction_checker_flags _ X_type X Γ t wt := - { | T with is_arity X_type X Γ _ T.π1 _ := + { | T with is_arity X_type X Γ _ T.π1 _ := { | true => true | false => let s := @sort_of_type extraction_checker_flags _ X_type X Γ T.π1 _ in is_propositional s.π1 } }. Proof. - - intros. specialize_Σ H. destruct wt; sq. + - intros. specialize_Σ H. destruct wt; sq. pcuic. - intros. specialize_Σ H. destruct T as [T Ht]. cbn. destruct (Ht Σ H) as [[tT Hp]]. @@ -304,23 +304,23 @@ Equations? is_erasableb X_type X (Γ : context) (T : PCUICAst.term) Transparent is_arity type_of_typing. Lemma is_erasableP {X_type X} {Γ : context} {t : PCUICAst.term} - {wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t} : - reflect (forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> + {wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t} : + reflect (forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ isErasable Σ Γ t ∥) (is_erasableb X_type X Γ t wt). Proof. funelim (is_erasableb X_type X Γ t wt). - constructor. intros. pose proof (abstract_env_ext_wf _ H) as [wf]. - destruct type_of_typing as [x Hx]. cbn -[is_arity sort_of_type] in *. - destruct (Hx _ H) as [[HT ?]]. - move/is_arityP: Heq => / (_ _ H) [T' [redT' isar]]. specialize_Σ H. + destruct type_of_typing as [x Hx]. cbn -[is_arity sort_of_type] in *. + destruct (Hx _ H) as [[HT ?]]. + move/is_arityP: Heq => / (_ _ H) [T' [redT' isar]]. specialize_Σ H. sq. red. exists T'. eapply type_reduction_closed in HT. - 2: eassumption. eauto. - - destruct type_of_typing as [x Hx]. cbn -[sort_of_type is_arity] in *. + 2: eassumption. eauto. + - destruct type_of_typing as [x Hx]. cbn -[sort_of_type is_arity] in *. destruct (sort_of_type _ _ _ _). cbn. destruct (is_propositional x0) eqn:isp; constructor. - * clear Heq. intros. - pose proof (abstract_env_ext_wf _ H) as [wf]. - specialize_Σ H. + * clear Heq. intros. + pose proof (abstract_env_ext_wf _ H) as [wf]. + specialize_Σ H. destruct Hx as [[HT ?]]. destruct s as [Hs]. sq. exists x; split => //. right. @@ -328,20 +328,20 @@ Proof. * pose proof (abstract_env_ext_exists X) as [[Σ wfΣ]]. move => / (_ _ wfΣ) [[T' [HT' er]]]. pose proof (abstract_env_ext_wf _ wfΣ) as [wf]. - move/is_arityP: Heq => nisa. - specialize_Σ wfΣ. + move/is_arityP: Heq => nisa. + specialize_Σ wfΣ. destruct Hx as [[HT ?]]. specialize (p _ HT'). destruct er as [isa|[u' [Hu' isp']]]. - { apply nisa. intros. rewrite (abstract_env_ext_irr _ H wfΣ). + { apply nisa. intros. rewrite (abstract_env_ext_irr _ H wfΣ). eapply invert_cumul_arity_r; tea. } { destruct s as [Hs]. unshelve epose proof (H := unique_sorting_equality_propositional _ _ wf Hs Hu' p) => //. reflexivity. reflexivity. congruence. } Qed. -Equations? is_erasable {X_type X} (Γ : context) (t : PCUICAst.term) - (wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) : - forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> +Equations? is_erasable {X_type X} (Γ : context) (t : PCUICAst.term) + (wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) : + forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> { ∥ isErasable Σ Γ t ∥ } + { ∥ isErasable Σ Γ t -> False ∥ } := is_erasable Γ T wt Σ wfΣ with inspect_bool (is_erasableb X_type X Γ T wt) := { | left ise => left _ @@ -350,7 +350,7 @@ Proof. pose proof (abstract_env_ext_wf _ wfΣ) as [wf]. now move/is_erasableP: ise => //. move/(elimN is_erasableP): nise. - intros; sq => ise. apply nise. + intros; sq => ise. apply nise. intros. now rewrite (abstract_env_ext_irr _ H wfΣ). Qed. @@ -359,14 +359,14 @@ Section Erase. Context (X_type : abstract_env_impl (cf := extraction_checker_flags)). Context (X : X_type.π2.π1). - (* Ltac sq' := + (* Ltac sq' := repeat match goal with | H : ∥ _ ∥ |- _ => destruct H; try clear H end; try eapply sq. *) (* Bug in equationa: it produces huge goals leading to stack overflow if we don't try reflexivity here. *) - Ltac Equations.Prop.DepElim.solve_equation c ::= + Ltac Equations.Prop.DepElim.solve_equation c ::= intros; try reflexivity; try Equations.Prop.DepElim.simplify_equation c; try match goal with @@ -375,13 +375,13 @@ Section Erase. end. Opaque is_erasableb. - + #[tactic="idtac"] - Equations? erase (Γ : context) (t : term) + Equations? erase (Γ : context) (t : term) (Ht : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) : E.term by struct t := { erase Γ t Ht with inspect_bool (is_erasableb X_type X Γ t Ht) := - { | left he := E.tBox; + { | left he := E.tBox; | right he with t := { | tRel i := E.tRel i | tVar n := E.tVar n @@ -404,7 +404,7 @@ Section Erase. | tCase ci p c brs := let c' := erase Γ c _ in let brs' := erase_brs Γ p brs _ in - E.tCase (ci.(ci_ind), ci.(ci_npar)) c' brs' + E.tCase (ci.(ci_ind), ci.(ci_npar)) c' brs' | tProj p c := let c' := erase Γ c _ in E.tProj p c' @@ -417,35 +417,35 @@ Section Erase. let mfix' := erase_cofix Γ' mfix _ in E.tCoFix mfix' n | tPrim p := E.tPrim (erase_prim_val p) } - } } + } } where erase_terms (Γ : context) (l : list term) (Hl : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ All (welltyped Σ Γ) l ∥) : list E.term := { erase_terms Γ [] _ := []; - erase_terms Γ (t :: ts) _ := + erase_terms Γ (t :: ts) _ := let t' := erase Γ t _ in let ts' := erase_terms Γ ts _ in t' :: ts' } (** We assume that there are no lets in contexts, so nothing has to be expanded. In particular, note that #|br.(bcontext)| = context_assumptions br.(bcontext) when no lets are present. *) - where erase_brs (Γ : context) p (brs : list (branch term)) + where erase_brs (Γ : context) p (brs : list (branch term)) (Ht : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ All (fun br => welltyped Σ (Γ ,,, inst_case_branch_context p br) (bbody br)) brs ∥) : - list (list name × E.term) := + list (list name × E.term) := { erase_brs Γ p [] Ht := []; - erase_brs Γ p (br :: brs) Hbrs := + erase_brs Γ p (br :: brs) Hbrs := let br' := erase (Γ ,,, inst_case_branch_context p br) (bbody br) _ in let brs' := erase_brs Γ p brs _ in (erase_context br.(bcontext), br') :: brs' } - + where erase_fix (Γ : context) (mfix : mfixpoint term) (Ht : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ All (fun d => isLambda d.(dbody) /\ welltyped Σ Γ d.(dbody)) mfix ∥) : E.mfixpoint E.term := { erase_fix Γ [] _ := []; - erase_fix Γ (d :: mfix) Hmfix := + erase_fix Γ (d :: mfix) Hmfix := let dbody' := erase Γ d.(dbody) _ in let dbody' := if isBox dbody' then match d.(dbody) with - (* We ensure that all fixpoint members start with a lambda, even a dummy one if the + (* We ensure that all fixpoint members start with a lambda, even a dummy one if the recursive definition is erased. *) | tLambda na _ _ => E.tLambda (binder_name na) E.tBox | _ => dbody' @@ -457,15 +457,15 @@ Section Erase. (Ht : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ All (fun d => welltyped Σ Γ d.(dbody)) mfix ∥) : E.mfixpoint E.term := { erase_cofix Γ [] _ := []; - erase_cofix Γ (d :: mfix) Hmfix := + erase_cofix Γ (d :: mfix) Hmfix := let dbody' := erase Γ d.(dbody) _ in let d' := {| E.dname := d.(dname).(binder_name); E.rarg := d.(rarg); E.dbody := dbody' |} in d' :: erase_cofix Γ mfix _ } . - Proof. + Proof. all: try clear b'; try clear f'; try clear t'; - try clear brs'; try clear c'; try clear br'; + try clear brs'; try clear c'; try clear br'; try clear d' dbody'; try clear erase; try clear erase_terms; try clear erase_brs; try clear erase_mfix. all: cbn; intros; subst; lazymatch goal with [ |- False ] => idtac | _ => try clear he end. all: try pose proof (abstract_env_ext_wf _ H) as [wf]; @@ -485,9 +485,9 @@ Section Erase. eexists; eauto. - eapply inversion_App in Ht as (? & ? & ? & ? & ? & ?); auto. eexists; eauto. - - move/is_erasableP: he. intro. apply he. intros. + - move/is_erasableP: he. intro. apply he. intros. pose proof (abstract_env_ext_wf _ H) as [wf]. - specialize_Σ H. destruct Ht as [ty Ht]. sq. + specialize_Σ H. destruct Ht as [ty Ht]. sq. eapply inversion_Ind in Ht as (? & ? & ? & ? & ? & ?) ; auto. red. eexists. split. econstructor; eauto. left. eapply isArity_subst_instance. @@ -511,7 +511,7 @@ Section Erase. - sq. now depelim Hmfix. - sq. now depelim Hmfix. Qed. - + End Erase. Lemma is_erasableb_irrel {X_type X Γ t} wt wt' : is_erasableb X_type X Γ t wt = is_erasableb X_type X Γ t wt'. @@ -522,13 +522,13 @@ Qed. Ltac iserasableb_irrel := match goal with - [ H : context [is_erasableb ?X_type ?X ?Γ ?t ?wt], Heq : inspect_bool _ = _ |- context [ is_erasableb _ _ _ _ ?wt'] ] => + [ H : context [is_erasableb ?X_type ?X ?Γ ?t ?wt], Heq : inspect_bool _ = _ |- context [ is_erasableb _ _ _ _ ?wt'] ] => generalize dependent H; rewrite (is_erasableb_irrel wt wt'); intros; rewrite Heq end. Ltac simp_erase := simp erase; rewrite -?erase_equation_1. -Lemma erase_irrel X_type X : +Lemma erase_irrel X_type X : (forall Γ t wt, forall wt', erase X_type X Γ t wt = erase X_type X Γ t wt') × (forall Γ l wt, forall wt', erase_terms X_type X Γ l wt = erase_terms X_type X Γ l wt') × (forall Γ p l wt, forall wt', erase_brs X_type X Γ p l wt = erase_brs X_type X Γ p l wt') × @@ -536,7 +536,7 @@ Lemma erase_irrel X_type X : (forall Γ l wt, forall wt', erase_cofix X_type X Γ l wt = erase_cofix X_type X Γ l wt'). Proof. apply: (erase_elim X_type X - (fun Γ t wt e => + (fun Γ t wt e => forall wt' : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t, e = erase X_type X Γ t wt') (fun Γ l awt e => forall wt', e = erase_terms X_type X Γ l wt') (fun Γ p l awt e => forall wt', e = erase_brs X_type X Γ p l wt') @@ -552,7 +552,7 @@ Proof. now rewrite (H0 (erase_obligation_20 X_type X Γ d mfix wt')). Qed. -Lemma erase_terms_eq X_type X Γ ts wt : +Lemma erase_terms_eq X_type X Γ ts wt : erase_terms X_type X Γ ts wt = map_All (erase X_type X Γ) ts wt. Proof. funelim (map_All (erase X_type X Γ) ts wt); cbn; auto. @@ -566,15 +566,15 @@ Opaque wf_reduction. Hint Constructors typing erases : core. Lemma erase_to_box {X_type X} {Γ t} (wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) : - forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> - let et := erase X_type X Γ t wt in + forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> + let et := erase X_type X Γ t wt in if is_box et then ∥ isErasable Σ Γ t ∥ else ~ ∥ isErasable Σ Γ t ∥. Proof. - cbn. intros. + cbn. intros. revert Γ t wt. apply (erase_elim X_type X - (fun Γ t wt e => + (fun Γ t wt e => if is_box e then ∥ isErasable Σ Γ t ∥ else ∥ isErasable Σ Γ t ∥ -> False) (fun Γ l awt e => True) (fun Γ p l awt e => True) @@ -583,25 +583,25 @@ Proof. all:try discriminate; auto. all:cbn -[isErasable]. - all:try solve [ match goal with - [ H : context [ is_erasableb ?X_type ?X ?Γ ?t ?Ht ] |- _ ] => + all:try solve [ match goal with + [ H : context [ is_erasableb ?X_type ?X ?Γ ?t ?Ht ] |- _ ] => destruct (@is_erasableP X_type X Γ t Ht) => // - end; intro; + end; intro; match goal with n : ~ _ |- _ => apply n end; intros ? HH; now rewrite (abstract_env_ext_irr _ HH H) ]. all:try bang. - - destruct (@is_erasableP X_type X Γ t Ht) => //. apply s; eauto. + - destruct (@is_erasableP X_type X Γ t Ht) => //. apply s; eauto. - cbn in *. rewrite is_box_tApp. destruct (@is_erasableP X_type X Γ (tApp f u) Ht) => //. destruct is_box. * cbn in *. clear H1. - pose proof (abstract_env_ext_wf _ H) as [wf]. cbn in *. + pose proof (abstract_env_ext_wf _ H) as [wf]. cbn in *. specialize_Σ H. destruct Ht, H0. eapply (EArities.Is_type_app _ _ _ [_]); eauto. eauto using typing_wf_local. * intro; apply n; intros. now rewrite (abstract_env_ext_irr _ H3 H). Defined. -Lemma erases_erase {X_type X Γ t} +Lemma erases_erase {X_type X Γ t} (wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> erases Σ Γ t (erase X_type X Γ t wt). Proof. @@ -609,9 +609,9 @@ Proof. apply (erase_elim X_type X (fun Γ t wt e => Σ;;; Γ |- t ⇝ℇ e) (fun Γ l awt e => All2 (erases Σ Γ) l e) - (fun Γ p l awt e => + (fun Γ p l awt e => All2 (fun (x : branch term) (x' : list name × E.term) => - (Σ;;; Γ,,, inst_case_branch_context p x |- + (Σ;;; Γ,,, inst_case_branch_context p x |- bbody x ⇝ℇ x'.2) * (erase_context (bcontext x) = x'.1)) l e) (fun Γ l awt e => All2 @@ -627,8 +627,8 @@ Proof. × Σ;;; Γ |- dbody d ⇝ℇ E.dbody d')) l e)) ; intros. all:try discriminate. all:try bang. - all:try match goal with - [ H : context [is_erasableb ?X_type ?X ?Γ ?t ?Ht ] |- _ ] => + all:try match goal with + [ H : context [is_erasableb ?X_type ?X ?Γ ?t ?Ht ] |- _ ] => destruct (@is_erasableP X_type X Γ t Ht) as [[H']|H'] => //; eauto ; try now eapply erases_box end. @@ -636,10 +636,10 @@ Proof. all:try destruct (abstract_env_ext_wf X H) as [wfΣ]. all: cbn in *; try constructor; auto; specialize_Σ H. - + - clear Heq. eapply nisErasable_Propositional in Ht; auto. - intro; eapply H'; intros. now rewrite (abstract_env_ext_irr _ H0 H). + intro; eapply H'; intros. now rewrite (abstract_env_ext_irr _ H0 H). - cbn. destruct (Ht _ H). destruct (inversion_Case _ _ X1) as [mdecl [idecl []]]; eauto. @@ -673,16 +673,16 @@ Qed. Transparent wf_reduction. -(** We perform erasure up-to the minimal global environment dependencies of the term: i.e. +(** We perform erasure up-to the minimal global environment dependencies of the term: i.e. we don't need to erase entries of the global environment that will not be used by the erased term. *) -Program Definition erase_constant_body X_type X - (cb : constant_body) - (Hcb : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ on_constant_decl (lift_typing typing) Σ cb ∥) : E.constant_body * KernameSet.t := +Program Definition erase_constant_body X_type X + (cb : constant_body) + (Hcb : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ on_constant_decl (lift_typing typing) Σ cb ∥) : E.constant_body * KernameSet.t := let '(body, deps) := match cb.(cst_body) with - | Some b => + | Some b => let b' := erase X_type X [] b _ in (Some b', term_global_deps b') | None => (None, KernameSet.empty) @@ -690,7 +690,7 @@ Program Definition erase_constant_body X_type X ({| E.cst_body := body; |}, deps). Next Obligation. Proof. - specialize_Σ H. sq. red in Hcb. + specialize_Σ H. sq. red in Hcb. rewrite <-Heq_anonymous in Hcb. now eexists. Qed. @@ -698,7 +698,7 @@ Definition erase_one_inductive_body (oib : one_inductive_body) : E.one_inductive (* Projection and constructor types are types, hence always erased *) let ctors := map (fun cdecl => EAst.mkConstructor cdecl.(cstr_name) cdecl.(cstr_arity)) oib.(ind_ctors) in let projs := map (fun pdecl => EAst.mkProjection pdecl.(proj_name)) oib.(ind_projs) in - let is_propositional := + let is_propositional := match destArity [] oib.(ind_type) with | Some (_, u) => is_propositional u | None => false (* dummy, impossible case *) @@ -719,7 +719,7 @@ Definition erase_mutual_inductive_body (mib : mutual_inductive_body) : E.mutual_ E.ind_bodies := bodies; |}. Lemma is_arity_irrel {X_type : abstract_env_impl} {X : X_type.π2.π1} - {X_type' : abstract_env_impl} {X' : X_type'.π2.π1} {Γ h h' t wt wt'} : + {X_type' : abstract_env_impl} {X' : X_type'.π2.π1} {Γ h h' t wt wt'} : Hlookup X_type X X_type' X' -> is_arity X_type X Γ h t wt = is_arity X_type' X' Γ h' t wt'. Proof. @@ -760,7 +760,7 @@ Proof. destruct x => //. Qed. - Lemma extends_lookup_env {cf Σ Σ' kn d} : wf Σ' -> extends_decls Σ Σ' -> + Lemma extends_lookup_env {cf Σ Σ' kn d} : wf Σ' -> extends_decls Σ Σ' -> lookup_env Σ kn = Some d -> lookup_env Σ' kn = Some d. Proof. destruct Σ as [univs Σ]. @@ -768,9 +768,9 @@ Qed. intros wf [Σ'' []]. cbn in *. subst univs'. induction x in Σ, Σ', e, wf |- *. cbn in e. now subst Σ'. intros hl. - rewrite e; cbn. + rewrite e; cbn. case: eqb_spec. - intros ->. + intros ->. eapply lookup_global_Some_fresh in hl. rewrite e in wf. destruct wf as [_ ond]; depelim ond. destruct o as [f ? ? ? ]. cbn in *. eapply Forall_app in f as []. contradiction. @@ -781,11 +781,11 @@ Qed. Qed. Lemma is_erasableb_irrel_global_env {X_type X X_type' X'} {Γ t wt wt'} : - (forall Σ Σ' : global_env_ext, abstract_env_ext_rel X Σ -> + (forall Σ Σ' : global_env_ext, abstract_env_ext_rel X Σ -> abstract_env_ext_rel X' Σ' -> ∥ extends_decls Σ' Σ ∥ /\ (Σ.2 = Σ'.2)) -> is_erasableb X_type X Γ t wt = is_erasableb X_type' X' Γ t wt'. Proof. - intro ext. + intro ext. (* ext eqext. *) assert (hl : Hlookup X_type X X_type' X'). { red. intros. specialize (ext _ _ H H0) as [[?] ?]. @@ -803,7 +803,7 @@ Proof. set(ty := (type_of_typing X_type' _ _ _ wt')) in *. set(ty' := (type_of_typing X_type _ _ _ wt)) in *. assert (ty.π1 = ty'.π1). - { subst ty ty'. unfold type_of_typing. symmetry. + { subst ty ty'. unfold type_of_typing. symmetry. eapply infer_irrel => //. } clearbody ty. clearbody ty'. destruct ty, ty'. cbn in H. subst x0. @@ -820,28 +820,28 @@ Qed. Ltac iserasableb_irrel_env := match goal with - [ H : context [is_erasableb ?X_type ?X ?Γ ?t ?wt], Heq : inspect_bool _ = _ |- context [ is_erasableb _ _ _ _ ?wt'] ] => + [ H : context [is_erasableb ?X_type ?X ?Γ ?t ?wt], Heq : inspect_bool _ = _ |- context [ is_erasableb _ _ _ _ ?wt'] ] => generalize dependent H; rewrite (@is_erasableb_irrel_global_env _ _ _ _ _ _ wt wt') //; intros; rewrite Heq end. Lemma erase_irrel_global_env {X_type X X_type' X'} {Γ t wt wt'} : - (forall Σ Σ' : global_env_ext, abstract_env_ext_rel X Σ -> + (forall Σ Σ' : global_env_ext, abstract_env_ext_rel X Σ -> abstract_env_ext_rel X' Σ' -> ∥ extends_decls Σ' Σ ∥ /\ (Σ.2 = Σ'.2)) -> erase X_type X Γ t wt = erase X_type' X' Γ t wt'. Proof. - intros ext. + intros ext. move: wt'. eapply (erase_elim X_type X - (fun Γ t wt e => - forall (wt' : forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> welltyped Σ' Γ t), + (fun Γ t wt e => + forall (wt' : forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> welltyped Σ' Γ t), e = erase X_type' X' Γ t wt') (fun Γ l awt e => forall wt', e = erase_terms X_type' X' Γ l wt') - (fun Γ p l awt e => forall wt', + (fun Γ p l awt e => forall wt', e = erase_brs X_type' X' Γ p l wt') - (fun Γ l awt e => forall wt', + (fun Γ l awt e => forall wt', e = erase_fix X_type' X' Γ l wt') - (fun Γ l awt e => forall wt', + (fun Γ l awt e => forall wt', e = erase_cofix X_type' X' Γ l wt')). all:intros *; intros; simp_erase. simp erase. @@ -855,7 +855,7 @@ Proof. Qed. Lemma erase_constant_body_suffix {X_type X X_type' X'} {cb ondecl ondecl'} : -(forall Σ Σ' : global_env_ext, abstract_env_ext_rel X Σ -> +(forall Σ Σ' : global_env_ext, abstract_env_ext_rel X Σ -> abstract_env_ext_rel X' Σ' -> ∥ extends_decls Σ' Σ ∥ /\ (Σ.2 = Σ'.2)) -> erase_constant_body X_type X cb ondecl = erase_constant_body X_type' X' cb ondecl'. Proof. @@ -877,7 +877,7 @@ Proof. split; cbn; auto. Qed. -Program Fixpoint erase_global_decls {X_type : abstract_env_impl} (deps : KernameSet.t) (X : X_type.π1) (decls : global_declarations) +Program Fixpoint erase_global_decls {X_type : abstract_env_impl} (deps : KernameSet.t) (X : X_type.π1) (decls : global_declarations) (prop : forall Σ : global_env, abstract_env_rel X Σ -> Σ.(declarations) = decls) : E.global_declarations := match decls with | [] => [] @@ -900,9 +900,9 @@ Program Fixpoint erase_global_decls {X_type : abstract_env_impl} (deps : Kername ((kn, E.InductiveDecl mib') :: X'') else erase_global_decls deps X' decls _ end. -Next Obligation. - pose proof (abstract_env_wf _ H) as [wf]. - pose proof (abstract_env_exists X) as [[? HX]]. +Next Obligation. + pose proof (abstract_env_wf _ H) as [wf]. + pose proof (abstract_env_exists X) as [[? HX]]. pose proof (abstract_env_wf _ HX) as [wfX]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). { now eexists. } @@ -911,59 +911,59 @@ Next Obligation. subst. sq. destruct wfX. depelim o0. destruct o1. split => //. Qed. Next Obligation. - pose proof (abstract_env_ext_wf _ H) as [wf]. - pose proof (abstract_env_exists (abstract_pop_decls X)) as [[? HX']]. + pose proof (abstract_env_ext_wf _ H) as [wf]. + pose proof (abstract_env_exists (abstract_pop_decls X)) as [[? HX']]. pose proof (abstract_env_wf _ HX') as [wfX']. - pose proof (abstract_env_exists X) as [[? HX]]. + pose proof (abstract_env_exists X) as [[? HX]]. pose proof (abstract_env_wf _ HX) as [wfX]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). { now eexists. } pose proof (abstract_pop_decls_correct X decls prop' _ _ HX HX') as [? []]. - pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ HX' H). + pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ HX' H). clear H HX'. specialize (prop _ HX). destruct x, Σ as [[] u], H0; cbn in *. subst. sq. inversion H3. subst. clear H3. destruct wfX. cbn in *. rewrite prop in o0. depelim o0. destruct o1. exact on_global_decl_d. Qed. Next Obligation. - pose proof (abstract_env_exists X) as [[? HX]]. + pose proof (abstract_env_exists X) as [[? HX]]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). { now eexists. } now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). -Qed. -Next Obligation. -pose proof (abstract_env_exists X) as [[? HX]]. +Qed. +Next Obligation. +pose proof (abstract_env_exists X) as [[? HX]]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). { now eexists. } now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). -Qed. +Qed. Next Obligation. - pose proof (abstract_env_exists X) as [[? HX]]. + pose proof (abstract_env_exists X) as [[? HX]]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). { now eexists. } now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). -Qed. +Qed. Next Obligation. -pose proof (abstract_env_exists X) as [[? HX]]. +pose proof (abstract_env_exists X) as [[? HX]]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). { now eexists. } now pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). -Qed. +Qed. Lemma erase_global_decls_irr X_type deps (X:X_type.π1) decls prf prf' : erase_global_decls deps X decls prf = erase_global_decls deps X decls prf'. -Proof. +Proof. revert X deps prf prf'. induction decls; eauto. intros. destruct a as [kn []]; cbn. - destruct KernameSet.mem; cbn. erewrite erase_constant_body_suffix. f_equal. - eapply IHdecls. intros. + eapply IHdecls. intros. pose proof (abstract_env_exists (abstract_pop_decls X)) as [[env wf]]. - rewrite (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ wf H). - now rewrite (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ wf H0). + rewrite (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ wf H). + now rewrite (abstract_make_wf_env_ext_correct (abstract_pop_decls X) (cst_universes c) _ _ _ wf H0). apply IHdecls. - destruct KernameSet.mem; cbn. f_equal. eapply IHdecls. - apply IHdecls. + apply IHdecls. Qed. Definition global_erased_with_deps (Σ : global_env) (Σ' : EAst.global_declarations) kn := @@ -973,12 +973,12 @@ Definition global_erased_with_deps (Σ : global_env) (Σ' : EAst.global_declarat erases_constant_body (Σ, cst_universes cst) cst cst' /\ (forall body : EAst.term, EAst.cst_body cst' = Some body -> erases_deps Σ Σ' body)) \/ - (exists mib mib', declared_minductive Σ kn mib /\ + (exists mib mib', declared_minductive Σ kn mib /\ EGlobalEnv.declared_minductive Σ' kn mib' /\ erases_mutual_inductive_body mib mib'). -Definition includes_deps (Σ : global_env) (Σ' : EAst.global_declarations) deps := - forall kn, +Definition includes_deps (Σ : global_env) (Σ' : EAst.global_declarations) deps := + forall kn, KernameSet.In kn deps -> global_erased_with_deps Σ Σ' kn. @@ -1011,7 +1011,7 @@ Qed. Definition declared_kn Σ kn := ∥ ∑ decl, lookup_env Σ kn = Some decl ∥. -Lemma term_global_deps_spec {cf} {Σ : global_env_ext} {Γ t et T} : +Lemma term_global_deps_spec {cf} {Σ : global_env_ext} {Γ t et T} : wf Σ.1 -> Σ ;;; Γ |- t : T -> Σ;;; Γ |- t ⇝ℇ et -> @@ -1020,7 +1020,7 @@ Proof. intros wf wt er. induction er in T, wt |- * using erases_forall_list_ind; cbn in *; try solve [constructor]; intros kn' hin; - repeat match goal with + repeat match goal with | [ H : KernameSet.In _ KernameSet.empty |- _ ] => now apply KernameSet.empty_spec in hin | [ H : KernameSet.In _ (KernameSet.union _ _) |- _ ] => @@ -1059,7 +1059,7 @@ Proof. destruct H0. destruct X1 as [br' [[T' HT] ?]]. eauto. - + - eapply KernameSet.singleton_spec in H0; subst. apply inversion_Proj in wt as (?&?&?&?&?&?&?&?&?&?); eauto. destruct d as [[[d _] _] _]. red in d. eexists; eauto. @@ -1089,7 +1089,7 @@ Qed. Global Remove Hints erases_deps_eval : core. -Lemma erase_global_erases_deps {Σ} {Σ' : EAst.global_declarations} {Γ t et T} : +Lemma erase_global_erases_deps {Σ} {Σ' : EAst.global_declarations} {Γ t et T} : wf_ext Σ -> Σ;;; Γ |- t : T -> Σ;;; Γ |- t ⇝ℇ et -> @@ -1099,7 +1099,7 @@ Proof. intros wf wt er. induction er in er, t, T, wf, wt |- * using erases_forall_list_ind; cbn in *; try solve [constructor]; intros Σer; - repeat match goal with + repeat match goal with | [ H : includes_deps _ _ (KernameSet.union _ _ ) |- _ ] => apply includes_deps_union in H as [? ?] end. @@ -1143,7 +1143,7 @@ Proof. destruct x1 as [x1 hnth]. red in x1, declm. rewrite x1 in declm. noconf declm. eapply Forall2_nth_error_left in H1; eauto. destruct H1 as [? [? ?]]. - eapply erases_deps_tCase; eauto. + eapply erases_deps_tCase; eauto. split; eauto. split; eauto. destruct H1. eapply In_Forall in H3. @@ -1155,7 +1155,7 @@ Proof. simpl. intuition auto. eexists ; eauto. now rewrite -(PCUICCasesContexts.inst_case_branch_context_eq a). ELiftSubst.solve_all. destruct a0 as [T' HT]. eauto. - + - apply inversion_Proj in wt as (?&?&?&?&?&?&?&?&?&?); eauto. destruct (proj1 d). specialize (H0 (inductive_mind p.(proj_ind))). forward H0. @@ -1165,7 +1165,7 @@ Proof. destruct H0 as [mib [mib' [declm [declm' em]]]]. assert (mib = x0). { destruct d as [[[]]]. - red in H0, declm. rewrite H0 in declm. now noconf declm. } + red in H0, declm. rewrite H0 in declm. now noconf declm. } subst x0. pose proof em as em'. destruct em'. eapply Forall2_nth_error_left in H0 as (x' & ? & ?); eauto. @@ -1182,7 +1182,7 @@ Proof. split => //. 2:split; eauto. split; eauto. split; eauto. rewrite -H4. symmetry; apply d. - + - constructor. apply inversion_Fix in wt as (?&?&?&?&?&?&?); eauto. eapply All_Forall. eapply includes_deps_fold in Σer as [_ Σer]. @@ -1196,20 +1196,20 @@ Proof. eapply In_Forall in Σer. eapply Forall_All in Σer. eapply Forall2_All2 in H. - ELiftSubst.solve_all. Unshelve. + ELiftSubst.solve_all. Unshelve. Qed. Lemma erases_weakeninv_env {Σ Σ' : global_env_ext} {Γ t t' T} : - wf Σ' -> extends_decls Σ Σ' -> + wf Σ' -> extends_decls Σ Σ' -> Σ ;;; Γ |- t : T -> erases Σ Γ t t' -> erases (Σ'.1, Σ.2) Γ t t'. Proof. intros wfΣ' ext Hty. eapply (env_prop_typing ESubstitution.erases_extends); tea. eapply extends_decls_wf; tea. -Qed. - -Lemma erases_deps_weaken kn d (Σ : global_env) (Σ' : EAst.global_declarations) t : +Qed. + +Lemma erases_deps_weaken kn d (Σ : global_env) (Σ' : EAst.global_declarations) t : wf (add_global_decl Σ (kn, d)) -> erases_deps Σ Σ' t -> erases_deps (add_global_decl Σ (kn, d)) Σ' t. @@ -1234,7 +1234,7 @@ Proof. simpl. split => //; eexists [(kn, d)]; intuition eauto. - econstructor; eauto. eapply weakening_env_declared_constructor; eauto; tc. - eapply extends_decls_extends. econstructor; try reflexivity. eexists [(_, _)]; reflexivity. + eapply extends_decls_extends. econstructor; try reflexivity. eexists [(_, _)]; reflexivity. - econstructor; eauto. red. destruct H. split; eauto. red in H. red. @@ -1251,18 +1251,18 @@ Proof. eapply lookup_env_Some_fresh in H. subst kn. destruct X1. contradiction. Qed. -Lemma lookup_env_ext {Σ kn kn' d d'} : +Lemma lookup_env_ext {Σ kn kn' d d'} : wf (add_global_decl Σ (kn', d')) -> lookup_env Σ kn = Some d -> kn <> kn'. Proof. - intros wf hl. + intros wf hl. eapply lookup_env_Some_fresh in hl. inv wf. inv X. destruct (eqb_spec kn kn'); subst; destruct X1; congruence. Qed. -Lemma lookup_env_cons_disc {Σ kn kn' d} : +Lemma lookup_env_cons_disc {Σ kn kn' d} : kn <> kn' -> lookup_env (add_global_decl Σ (kn', d)) kn = lookup_env Σ kn. Proof. @@ -1270,7 +1270,7 @@ Proof. destruct (eqb_spec kn kn'); congruence. Qed. -Lemma elookup_env_cons_disc {Σ kn kn' d} : +Lemma elookup_env_cons_disc {Σ kn kn' d} : kn <> kn' -> EGlobalEnv.lookup_env ((kn', d) :: Σ) kn = EGlobalEnv.lookup_env Σ kn. Proof. @@ -1278,7 +1278,7 @@ Proof. destruct (eqb_spec kn kn'); congruence. Qed. -Lemma global_erases_with_deps_cons kn kn' d d' Σ Σ' : +Lemma global_erases_with_deps_cons kn kn' d d' Σ Σ' : wf (add_global_decl Σ (kn', d)) -> global_erased_with_deps Σ Σ' kn -> global_erased_with_deps (add_global_decl Σ (kn', d)) ((kn', d') :: Σ') kn. @@ -1288,11 +1288,11 @@ Proof. exists cst. split. red in declc |- *. unfold lookup_env in *. rewrite lookup_env_cons_fresh //. - { eapply lookup_env_Some_fresh in declc. destruct X1. + { eapply lookup_env_Some_fresh in declc. destruct X1. intros <-; contradiction. } exists cst'. unfold EGlobalEnv.declared_constant. rewrite EGlobalEnv.elookup_env_cons_fresh //. - { eapply lookup_env_Some_fresh in declc. destruct X1. + { eapply lookup_env_Some_fresh in declc. destruct X1. intros <-; contradiction. } red in ebody. unfold erases_constant_body. destruct (cst_body cst) eqn:bod; destruct (E.cst_body cst') eqn:bod' => //. @@ -1315,7 +1315,7 @@ Proof. now rewrite elookup_env_cons_disc. Qed. -Lemma global_erases_with_deps_weaken kn kn' d Σ Σ' : +Lemma global_erases_with_deps_weaken kn kn' d Σ Σ' : wf (add_global_decl Σ (kn', d)) -> global_erased_with_deps Σ Σ' kn -> global_erased_with_deps (add_global_decl Σ (kn', d)) Σ' kn. @@ -1350,46 +1350,46 @@ Proof. now epose proof (lookup_env_ext wf Hm). Qed. -Lemma erase_constant_body_correct X_type X cb +Lemma erase_constant_body_correct X_type X cb (onc : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ on_constant_decl (lift_typing typing) Σ cb ∥) : - forall Σ Σ', abstract_env_ext_rel X Σ -> + forall Σ Σ', abstract_env_ext_rel X Σ -> wf Σ' -> extends_decls Σ Σ' -> erases_constant_body (Σ', Σ.2) cb (fst (erase_constant_body X_type X cb onc)). Proof. red. destruct cb as [name [bod|] univs]; simpl; eauto. intros. set (ecbo := erase_constant_body_obligation_1 X_type X _ _ _ _). clearbody ecbo. - cbn in *. specialize_Σ H. sq. + cbn in *. specialize_Σ H. sq. eapply (erases_weakeninv_env (Σ := Σ) (Σ' := (Σ', univs))); simpl; eauto. now eapply erases_erase. Qed. -Lemma erase_constant_body_correct' {X_type X} {cb} - {onc : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ on_constant_decl (lift_typing typing) Σ cb ∥} +Lemma erase_constant_body_correct' {X_type X} {cb} + {onc : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ on_constant_decl (lift_typing typing) Σ cb ∥} {body} : EAst.cst_body (fst (erase_constant_body X_type X cb onc)) = Some body -> - forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> + forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ ∑ t T, (Σ ;;; [] |- t : T) * (Σ ;;; [] |- t ⇝ℇ body) * (term_global_deps body = snd (erase_constant_body X_type X cb onc)) ∥. Proof. intros. destruct cb as [name [bod|] univs]; simpl; [| now simpl in H]. - simpl in H. noconf H. + simpl in H. noconf H. set (obl :=(erase_constant_body_obligation_1 X_type X {| cst_type := name; cst_body := Some bod; - cst_universes := univs |} onc bod eq_refl)). clearbody obl. cbn in *. + cst_universes := univs |} onc bod eq_refl)). clearbody obl. cbn in *. specialize_Σ H0. destruct (obl _ H0). sq. - exists bod, A; intuition auto. now eapply erases_erase. + exists bod, A; intuition auto. now eapply erases_erase. Qed. -Lemma erases_mutual {Σ mdecl m} : +Lemma erases_mutual {Σ mdecl m} : on_inductive cumulSpec0 (lift_typing typing) (Σ, ind_universes m) mdecl m -> erases_mutual_inductive_body m (erase_mutual_inductive_body m). Proof. intros oni. destruct m; constructor; simpl; auto. eapply onInductives in oni; simpl in *. - assert (Alli (fun i oib => + assert (Alli (fun i oib => match destArity [] oib.(ind_type) with Some _ => True | None => False end) 0 ind_bodies0). { eapply Alli_impl; eauto. simpl. intros n x []. simpl in *. rewrite ind_arity_eq. @@ -1406,7 +1406,7 @@ Proof. Qed. Lemma erase_global_includes X_type (X:X_type.π1) deps decls prf deps' : - (forall d, KernameSet.In d deps' -> + (forall d, KernameSet.In d deps' -> forall Σ : global_env, abstract_env_rel X Σ -> ∥ ∑ decl, lookup_env Σ d = Some decl ∥) -> KernameSet.subset deps' deps -> forall Σ : global_env, abstract_env_rel X Σ -> @@ -1434,41 +1434,41 @@ Proof. unfold lookup_env; simpl; rewrite (prf _ wfΣ). cbn. rewrite eq_kername_refl //. pose proof (sub _ hin) as indeps. eapply KernameSet.mem_spec in indeps. - unfold EGlobalEnv.declared_constant. - edestruct (H _ hin) as [[decl hd]]; eauto. + unfold EGlobalEnv.declared_constant. + edestruct (H _ hin) as [[decl hd]]; eauto. eexists; intuition eauto. rewrite indeps. cbn. rewrite eq_kername_refl. reflexivity. eapply (erase_constant_body_correct _ _ _ _ (Σpop , _)); eauto. - rewrite <- (abstract_make_wf_env_ext_correct Xpop (cst_universes c) _ Σpop Σmake wfpop wfmake); eauto. + rewrite <- (abstract_make_wf_env_ext_correct Xpop (cst_universes c) _ Σpop Σmake wfpop wfmake); eauto. red. simpl. unshelve epose (abstract_pop_decls_correct X decls _ Σ Σpop wfΣ wfpop). { intros. now eexists. } split => //. intuition eauto. exists [(kn, ConstantDecl c)]; intuition eauto. rewrite H0; eauto. - now destruct a. + now destruct a. rewrite indeps. unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σpop wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. { intros. now eexists. } pose (prf' := prf _ wfΣ). - destruct Σ. cbn in *. rewrite Hpop' Hpop'' prf'. rewrite <- Hpop at 1. - eapply (erases_deps_cons Σpop). + destruct Σ. cbn in *. rewrite Hpop' Hpop'' prf'. rewrite <- Hpop at 1. + eapply (erases_deps_cons Σpop). rewrite <- Hpop'. apply wf. - rewrite Hpop. rewrite prf' in wf. destruct wf. now rewrite Hpop'' Hpop' in o0. + rewrite Hpop. rewrite prf' in wf. destruct wf. now rewrite Hpop'' Hpop' in o0. - pose proof (erase_constant_body_correct' H0). specialize_Σ wfmake. + pose proof (erase_constant_body_correct' H0). specialize_Σ wfmake. sq. destruct H1 as [bod [bodty [[Hbod Hebod] Heqdeps]]]. - rewrite (abstract_make_wf_env_ext_correct Xpop (cst_universes c) _ Σpop Σmake wfpop wfmake) in Hbod, Hebod. + rewrite (abstract_make_wf_env_ext_correct Xpop (cst_universes c) _ Σpop Σmake wfpop wfmake) in Hbod, Hebod. eapply (erase_global_erases_deps (Σ := (Σpop, cst_universes c))); simpl; auto. { constructor; simpl; auto. depelim wf. rewrite Hpop' Hpop'' in o0. - cbn in o0, o. rewrite prf' in o0. rewrite <- Hpop in o0. rewrite Hpop' in o. clear -o o0. + cbn in o0, o. rewrite prf' in o0. rewrite <- Hpop in o0. rewrite Hpop' in o. clear -o o0. now depelim o0. depelim wf. rewrite Hpop' in o0. cbn in o0, o. rewrite prf' in o0. rewrite <- Hpop in o0. clear -o0. depelim o0. now destruct o. } - all: eauto. - apply IHdecls; eauto. + all: eauto. + apply IHdecls; eauto. { intros. pose proof (abstract_env_wf _ wfpop) as [wf']. - destruct Σpop. cbn in *. clear prf'. subst. + destruct Σpop. cbn in *. clear prf'. subst. unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wfΣ H2) as [Hpop Hpop']. { intros. now eexists. } destruct Σ. cbn in *. subst. @@ -1477,7 +1477,7 @@ Proof. intros x hin'. eapply KernameSet.union_spec. right; auto. now rewrite -Heqdeps. } } { eexists m, _; intuition eauto. - simpl. rewrite /declared_minductive /lookup_env prf; eauto. + simpl. rewrite /declared_minductive /lookup_env prf; eauto. simpl. rewrite eq_kername_refl. reflexivity. specialize (sub _ hin). eapply KernameSet.mem_spec in sub. @@ -1489,7 +1489,7 @@ Proof. eapply on_declared_minductive in H0; tea. now eapply erases_mutual. } - * intros ikn Hi. + * intros ikn Hi. destruct d as [|]. ++ simpl. destruct (KernameSet.mem kn deps) eqn:eqkn. set (Xpop := abstract_pop_decls X). @@ -1504,16 +1504,16 @@ Proof. 3:{ eapply KernameSet.singleton_spec => //. } intros. eapply KernameSet.singleton_spec in H0. - pose proof (abstract_env_irr _ H1 wfpop). subst. + pose proof (abstract_env_irr _ H1 wfpop). subst. sq; exists decl; eauto. eapply KernameSet.subset_spec. intros ? ?. eapply KernameSet.union_spec. left. eapply KernameSet.singleton_spec in H0; subst. now eapply sub. - + cbn. set (Xpop := abstract_pop_decls X). epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - pose proof (abstract_env_wf _ wfpop) as [wfΣp]. + pose proof (abstract_env_wf _ wfpop) as [wfΣp]. unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σp wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. { intros. now eexists. } pose proof (prf _ wfΣ). destruct Σ. cbn in *. subst. @@ -1521,14 +1521,14 @@ Proof. eapply IHdecls => //. 3:now eapply KernameSet.singleton_spec. intros d ind%KernameSet.singleton_spec. - intros. pose proof (abstract_env_irr _ H0 wfpop). subst. + intros. pose proof (abstract_env_irr _ H0 wfpop). subst. sq; eexists; eauto. eapply KernameSet.subset_spec. intros ? hin'. eapply sub. eapply KernameSet.singleton_spec in hin'. now subst. ++ simpl. set (Xpop := abstract_pop_decls X). epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. - pose proof (abstract_env_wf _ wfpop) as [wfΣp]. + pose proof (abstract_env_wf _ wfpop) as [wfΣp]. unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σp wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. { intros. now eexists. } pose proof (prf _ wfΣ). destruct Σ. cbn in *. subst. @@ -1538,23 +1538,23 @@ Proof. 3:{ eapply KernameSet.singleton_spec => //. } intros. eapply KernameSet.singleton_spec in H0. subst. - pose proof (abstract_env_irr _ H1 wfpop). subst. + pose proof (abstract_env_irr _ H1 wfpop). subst. sq; eexists; eauto. eapply KernameSet.subset_spec. intros ? ?. eapply KernameSet.singleton_spec in H0; subst. now eapply sub. } - + { eapply (global_erases_with_deps_weaken _ kn (InductiveDecl _) Σp). eauto. eapply (IHdecls Xpop _ _ (KernameSet.singleton i)) => //. 3:now eapply KernameSet.singleton_spec. intros d ind%KernameSet.singleton_spec. - intros. pose proof (abstract_env_irr _ H0 wfpop). subst. + intros. pose proof (abstract_env_irr _ H0 wfpop). subst. sq; eexists; eauto. eapply KernameSet.subset_spec. - intros ? hin'. eapply sub. eapply KernameSet.singleton_spec in hin'. now subst. } + intros ? hin'. eapply sub. eapply KernameSet.singleton_spec in hin'. now subst. } Qed. -Lemma erase_correct (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) +Lemma erase_correct (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) univs wfext t v Σ' t' deps decls prf : let Xext := abstract_make_wf_env_ext X univs wfext in forall wt : forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t, @@ -1562,7 +1562,7 @@ Lemma erase_correct (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) KernameSet.subset (term_global_deps t') deps -> erase_global_decls deps X decls prf = Σ' -> (forall Σ : global_env, abstract_env_rel X Σ -> Σ |-p t ▷ v) -> - forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> + forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> exists v', Σ ;;; [] |- v ⇝ℇ v' /\ ∥ Σ' ⊢ t' ▷ v' ∥. Proof. intros Xext wt. @@ -1574,10 +1574,10 @@ Proof. specialize (H _ wfΣex). unshelve epose proof (erase_global_erases_deps (Σ' := Σ') wfΣ wt' H _); cycle 2. rewrite <- Ht'. - eapply erase_global_includes; eauto. + eapply erase_global_includes; eauto. intros. eapply term_global_deps_spec in H; eauto. now rewrite (abstract_make_wf_env_ext_correct X univs wfext Σ _ H1 wfΣex) in H. - + epose proof (abstract_env_exists X) as [[Σ wfΣX]]. now rewrite (abstract_make_wf_env_ext_correct X univs wfext Σ _ wfΣX wfΣex). epose proof (abstract_env_exists X) as [[Σ wfΣX]]. @@ -1585,7 +1585,7 @@ Proof. rewrite (abstract_make_wf_env_ext_correct X univs wfext _ _ wfΣX wfΣex); eauto. Qed. -Lemma global_env_ind (P : global_env -> Type) +Lemma global_env_ind (P : global_env -> Type) (Pnil : forall univs retro, P {| universes := univs; declarations := []; retroknowledge := retro |}) (Pcons : forall (Σ : global_env) d, P Σ -> P (add_global_decl Σ d)) (Σ : global_env) : P Σ. @@ -1598,19 +1598,19 @@ Qed. Lemma on_global_env_ind (P : forall Σ : global_env, wf Σ -> Type) (Pnil : forall univs retro (onu : on_global_univs univs), P {| universes := univs; declarations := []; retroknowledge := retro |} (onu, globenv_nil _ _ _ _)) - (Pcons : forall (Σ : global_env) kn d (wf : wf Σ) + (Pcons : forall (Σ : global_env) kn d (wf : wf Σ) (Hfresh : fresh_global kn Σ.(declarations)) (udecl := PCUICLookup.universes_decl_of_decl d) (onud : on_udecl Σ.(universes) udecl) - (pd : on_global_decl cumulSpec0 (lift_typing typing) + (pd : on_global_decl cumulSpec0 (lift_typing typing) ({| universes := Σ.(universes); declarations := Σ.(declarations); retroknowledge := Σ.(retroknowledge) |}, udecl) kn d), - P Σ wf -> P (add_global_decl Σ (kn, d)) - (fst wf, globenv_decl _ _ Σ.(universes) Σ.(retroknowledge) Σ.(declarations) kn d (snd wf) + P Σ wf -> P (add_global_decl Σ (kn, d)) + (fst wf, globenv_decl _ _ Σ.(universes) Σ.(retroknowledge) Σ.(declarations) kn d (snd wf) {| kn_fresh := Hfresh ; on_udecl_udecl := onud ; on_global_decl_d := pd |})) (Σ : global_env) (wfΣ : wf Σ) : P Σ wfΣ. Proof. destruct Σ as [univs Σ]. destruct wfΣ; cbn in *. - induction o0. apply Pnil. destruct o1. + induction o0. apply Pnil. destruct o1. apply (Pcons {| universes := univs; declarations := Σ |} kn d (o, o0)). exact IHo0. Qed. @@ -1624,7 +1624,7 @@ Lemma leq_term_propositional_sorted_l {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> is_propositional u -> + Σ;;; Γ |- v' : tSort u' -> is_propositional u -> leq_universe (global_ext_constraints Σ) u' u. Proof. intros wfΣ leq hv hv' isp. @@ -1633,18 +1633,18 @@ Proof. - eapply leq_term_sprop_sorted_l; eauto. Qed. -Fixpoint map_erase (X_type:abstract_env_impl) (X : X_type.π2.π1) Γ - (ts : list term) - (H2 : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> +Fixpoint map_erase (X_type:abstract_env_impl) (X : X_type.π2.π1) Γ + (ts : list term) + (H2 : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> Forall (welltyped Σ Γ) ts) {struct ts}: list E.term. destruct ts as [ | t ts]. - exact []. -- eapply cons. refine (erase X_type X Γ t _). +- eapply cons. refine (erase X_type X Γ t _). 2: eapply (map_erase X_type X Γ ts). all: intros; specialize_Σ H; now inversion H2; subst. Defined. -Lemma map_erase_irrel X_type X Γ t H1 H2 : +Lemma map_erase_irrel X_type X Γ t H1 H2 : map_erase X_type X Γ t H1 = map_erase X_type X Γ t H2. Proof. epose proof (abstract_env_ext_exists X) as [[Σ wfΣX]]. @@ -1660,14 +1660,14 @@ Arguments map_erase _ _ _ _, _ _ _ {_}. Lemma erase_mkApps {X_type X} Γ t args H2 Ht Hargs : (forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> wf_local Σ Γ) -> (forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ~ ∥ isErasable Σ Γ (mkApps t args) ∥) -> - erase X_type X Γ (mkApps t args) H2 = + erase X_type X Γ (mkApps t args) H2 = E.mkApps (erase X_type X Γ t Ht) (map_erase X_type X Γ args Hargs). Proof. epose proof (abstract_env_ext_exists X) as [[Σ wfΣX]]. - pose proof (abstract_env_ext_wf X wfΣX) as [wf]. + pose proof (abstract_env_ext_wf X wfΣX) as [wf]. intros Hwflocal Herasable. induction args in t, H2, Ht, Hargs, Herasable |- *. - cbn. eapply erase_irrel. - - cbn [mkApps]. + - cbn [mkApps]. rewrite IHargs; clear IHargs. all: intros; specialize_Σ H; try pose proof (abstract_env_ext_wf _ H) as [wfH]. 1: inversion Hargs; eauto. @@ -1678,15 +1678,15 @@ Proof. unfold inspect. unfold erase_clause_1_clause_2. Unshelve. elim: is_erasableP. - + intros. exfalso. + + intros. exfalso. eapply Herasable; eauto. specialize_Σ wfΣX. destruct p. cbn. destruct H2. eapply Is_type_app; eauto. - + cbn [map_erase]. + + cbn [map_erase]. epose proof (fst (erase_irrel _ _)). cbn. intros he. f_equal => //. f_equal. eapply erase_irrel. eapply erase_irrel. - eapply map_erase_irrel. - Unshelve. 2: exact X. + eapply map_erase_irrel. + Unshelve. 2: exact X. Qed. Lemma map_erase_length X_type X Γ t H1 : length (map_erase X_type X Γ t H1) = length t. @@ -1699,12 +1699,12 @@ Local Hint Constructors expanded : expanded. Local Arguments erase_global_decls _ _ _ : clear implicits. Lemma lookup_env_erase X_type X deps decls prf kn d : - KernameSet.In kn deps -> + KernameSet.In kn deps -> forall Σ : global_env, abstract_env_rel X Σ -> lookup_env Σ kn = Some (InductiveDecl d) -> EGlobalEnv.lookup_env (erase_global_decls X_type deps X decls prf) kn = Some (EAst.InductiveDecl (erase_mutual_inductive_body d)). Proof. intros hin Σ wfΣ. pose proof (prf _ wfΣ). unfold lookup_env. rewrite H. clear H. - rewrite /lookup_env. + rewrite /lookup_env. induction decls in X, Σ , wfΣ ,prf, deps, hin |- *. - move=> /= //. - destruct a as [kn' d']. @@ -1728,25 +1728,25 @@ Proof. destruct KernameSet.mem. cbn. rewrite (negbTE (proj2 (neqb _ _) e')). eapply IHdecls => //; eauto. - eapply IHdecls => //; eauto. + eapply IHdecls => //; eauto. Qed. Lemma erase_global_declared_constructor X_type X ind c mind idecl cdecl deps decls prf: forall Σ : global_env, abstract_env_rel X Σ -> declared_constructor Σ (ind, c) mind idecl cdecl -> - KernameSet.In ind.(inductive_mind) deps -> - EGlobalEnv.declared_constructor (erase_global_decls X_type deps X decls prf) (ind, c) - (erase_mutual_inductive_body mind) (erase_one_inductive_body idecl) + KernameSet.In ind.(inductive_mind) deps -> + EGlobalEnv.declared_constructor (erase_global_decls X_type deps X decls prf) (ind, c) + (erase_mutual_inductive_body mind) (erase_one_inductive_body idecl) (EAst.mkConstructor cdecl.(cstr_name) cdecl.(cstr_arity)). Proof. intros Σ wfΣ [[]] Hin. - cbn in *. split. split. + cbn in *. split. split. - red in H |- *. now eapply lookup_env_erase. - cbn. now eapply map_nth_error. - cbn. erewrite map_nth_error; eauto. Qed. Import EGlobalEnv. -Lemma erase_global_decls_fresh X_type kn deps X decls heq : +Lemma erase_global_decls_fresh X_type kn deps X decls heq : let Σ' := erase_global_decls X_type deps X decls heq in PCUICAst.fresh_global kn decls -> fresh_global kn Σ'. @@ -1768,8 +1768,8 @@ Qed. From MetaCoq.Erasure Require Import EEtaExpandedFix. -Lemma erase_brs_eq X_type X Γ p ts wt : - erase_brs X_type X Γ p ts wt = +Lemma erase_brs_eq X_type X Γ p ts wt : + erase_brs X_type X Γ p ts wt = map_All (fun br wt => (erase_context (bcontext br), erase X_type X _ (bbody br) wt)) ts wt. Proof. funelim (map_All _ ts wt); cbn; auto. @@ -1777,14 +1777,14 @@ Proof. rewrite -H. eapply erase_irrel. Qed. -Lemma erase_fix_eq X_type X Γ ts wt : - erase_fix X_type X Γ ts wt = map_All (fun d wt => +Lemma erase_fix_eq X_type X Γ ts wt : + erase_fix X_type X Γ ts wt = map_All (fun d wt => let dbody' := erase X_type X _ (dbody d) (fun Σ abs => proj2 (wt Σ abs)) in let dbody' := if isBox dbody' then match d.(dbody) with | tLambda na _ _ => E.tLambda (binder_name na) E.tBox | _ => dbody' - end else dbody' + end else dbody' in {| E.dname := d.(dname).(binder_name); E.rarg := d.(rarg); E.dbody := dbody' |}) ts wt. Proof. @@ -1796,8 +1796,8 @@ Proof. rewrite -H. eapply erase_irrel. Qed. -Lemma erase_cofix_eq X_type X Γ ts wt : - erase_cofix X_type X Γ ts wt = map_All (fun d wt => +Lemma erase_cofix_eq X_type X Γ ts wt : + erase_cofix X_type X Γ ts wt = map_All (fun d wt => let dbody' := erase X_type X _ (dbody d) wt in {| E.dname := d.(dname).(binder_name); E.rarg := d.(rarg); E.dbody := dbody' |}) ts wt. Proof. @@ -1807,7 +1807,7 @@ Proof. rewrite -H. eapply erase_irrel. Qed. -Lemma isConstruct_erase X_type X Γ t wt : +Lemma isConstruct_erase X_type X Γ t wt : ~ (PCUICEtaExpand.isConstruct t || PCUICEtaExpand.isFix t || PCUICEtaExpand.isRel t) -> ~ (isConstruct (erase X_type X Γ t wt) || isFix (erase X_type X Γ t wt) || isRel (erase X_type X Γ t wt)). Proof. @@ -1826,17 +1826,17 @@ Proof. intros; now subst. Qed. Lemma isLambda_inv t : isLambda t -> exists na ty bod, t = tLambda na ty bod. Proof. destruct t => //; eauto. Qed. -Lemma erases_deps_erase (cf := config.extraction_checker_flags) - {X_type X} univs +Lemma erases_deps_erase (cf := config.extraction_checker_flags) + {X_type X} univs (wfΣ : forall Σ, (abstract_env_rel X Σ) -> ∥ wf_ext (Σ, univs) ∥) decls prf - (X' := abstract_make_wf_env_ext X univs wfΣ) Γ t + (X' := abstract_make_wf_env_ext X univs wfΣ) Γ t (wt : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t) : let et := erase X_type X' Γ t wt in let deps := EAstUtils.term_global_deps et in - forall Σ, (abstract_env_rel X Σ) -> + forall Σ, (abstract_env_rel X Σ) -> erases_deps Σ (erase_global_decls X_type deps X decls prf) et. Proof. - intros et deps Σ wf. + intros et deps Σ wf. pose proof (abstract_env_ext_exists X') as [[Σ' wfΣ']]. pose proof (wt _ wfΣ'). destruct H. pose proof (wfΣ _ wf) as [w]. rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ') in X0. @@ -1847,21 +1847,21 @@ Proof. intros. rewrite (abstract_env_irr _ H0 wf). eapply term_global_deps_spec in H; eauto. assumption. - eapply (erases_erase (X := X') (Γ := Γ)). + eapply (erases_erase (X := X') (Γ := Γ)). now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). - eapply KernameSet.subset_spec. reflexivity. - now cbn. + eapply KernameSet.subset_spec. reflexivity. + now cbn. Qed. -Lemma erases_deps_erase_weaken (cf := config.extraction_checker_flags) - {X_type X} univs +Lemma erases_deps_erase_weaken (cf := config.extraction_checker_flags) + {X_type X} univs (wfΣ : forall Σ, (abstract_env_rel X Σ) -> ∥ wf_ext (Σ, univs) ∥) decls prf - (X' := abstract_make_wf_env_ext X univs wfΣ) Γ t - (wt : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t) + (X' := abstract_make_wf_env_ext X univs wfΣ) Γ t + (wt : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t) deps : let et := erase X_type X' Γ t wt in let tdeps := EAstUtils.term_global_deps et in - forall Σ, (abstract_env_rel X Σ) -> + forall Σ, (abstract_env_rel X Σ) -> erases_deps Σ (erase_global_decls X_type (KernameSet.union deps tdeps) X decls prf) et. Proof. intros et tdeps Σ wf. @@ -1882,15 +1882,15 @@ Proof. now cbn. Qed. -Lemma eta_expand_erase {X_type X} Σ' {Γ t} +Lemma eta_expand_erase {X_type X} Σ' {Γ t} (wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) Γ' : - forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> + forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> PCUICEtaExpand.expanded Σ Γ' t -> erases_global Σ Σ' -> expanded Σ' Γ' (erase X_type X Γ t wt). Proof. intros Σ wfΣ exp deps. - pose proof (abstract_env_ext_wf _ wfΣ) as [wf]. + pose proof (abstract_env_ext_wf _ wfΣ) as [wf]. eapply expanded_erases. apply wf. eapply erases_erase; eauto. assumption. pose proof (wt _ wfΣ). destruct H as [T ht]. @@ -1904,7 +1904,7 @@ Lemma erase_global_closed X_type X deps decls prf : Proof. revert X prf deps. induction decls; [cbn; auto|]. - intros X prf deps. + intros X prf deps. destruct a as [kn d]. destruct d as []; simpl; destruct KernameSet.mem; set (Xpop := abstract_pop_decls X); @@ -1920,14 +1920,14 @@ Proof. pose proof (abstract_env_ext_exists Xmake) as [[Σmake wfmake]]. pose proof (abstract_env_ext_wf _ wfmake) as [[?]]. eapply erases_closed in H => //; eauto. - cbn. destruct (obl eq_refl _ wfmake). clear H. + cbn. destruct (obl eq_refl _ wfmake). clear H. now eapply PCUICClosedTyp.subject_closed in X0. + eapply IHdecls => //. + cbn [EGlobalEnv.closed_env forallb]. rewrite {1}/test_snd {1}/EGlobalEnv.closed_decl /=. eapply IHdecls => //. + eapply IHdecls => //. - Unshelve. eauto. + Unshelve. eauto. Qed. Import EWellformed. @@ -1941,11 +1941,11 @@ Section wffix. | tLambda N M => wf_fixpoints M | tApp u v => wf_fixpoints u && wf_fixpoints v | tLetIn na b b' => wf_fixpoints b && wf_fixpoints b' - | tCase ind c brs => + | tCase ind c brs => let brs' := forallb (wf_fixpoints ∘ snd) brs in wf_fixpoints c && brs' | tProj p c => wf_fixpoints c - | tFix mfix idx => + | tFix mfix idx => (idx isLambda d.(dbody) && wf_fixpoints d.(dbody)) mfix | tCoFix mfix idx => (idx //; + induction ed using erases_deps_forall_ind; intros => //; try solve [cbn in *; unfold wf_fix in *; rtoProp; intuition eauto; solve_all]. - cbn. red in H0. rewrite H0 //. - cbn -[lookup_constructor]. cbn. now destruct H0 as [[-> ->] ->]. - cbn in *. move/andP: H5 => [] cld clbrs. - cbn. apply/andP; split. apply/andP; split. + cbn. apply/andP; split. apply/andP; split. * now destruct H0 as [-> ->]. * now move/andP: H6. * move/andP: H6; solve_all. @@ -1979,7 +1979,7 @@ Proof. now rewrite (declared_projection_lookup H0). Qed. -Lemma erases_wf_fixpoints Σ Γ t t' : Σ;;; Γ |- t ⇝ℇ t' -> +Lemma erases_wf_fixpoints Σ Γ t t' : Σ;;; Γ |- t ⇝ℇ t' -> ErasureProperties.wellformed Σ t -> wf_fixpoints t'. Proof. induction 1 using erases_forall_list_ind; cbn; auto; try solve [rtoProp; repeat solve_all]. @@ -2001,8 +2001,8 @@ Proof. eapply erases_wf_fixpoints. eapply erases_erase; eauto. specialize (wt _ wf'). destruct (wfΣ _ wf). - unshelve eapply welltyped_wellformed in wt; eauto. - now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wf'). + unshelve eapply welltyped_wellformed in wt; eauto. + now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wf'). Qed. Lemma erase_wellformed (efl := all_env_flags) {X_type X} decls prf univs wfΣ {Γ t} wt @@ -2012,7 +2012,7 @@ wellformed (erase_global_decls X_type (term_global_deps t') X decls prf) #|Γ| t Proof. set (t' := erase _ _ _ _ _). cbn. epose proof (@erases_deps_erase X_type X univs wfΣ decls prf Γ t wt). - pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. pose proof (abstract_env_ext_exists X') as [[Σ' wf']]. pose proof (abstract_env_ext_wf _ wf') as [[?]]. epose proof (erases_deps_wellformed _ H #|Γ|). @@ -2020,9 +2020,9 @@ Proof. eapply (erases_closed _ Γ). destruct (wt _ wf'). cbn in X. destruct (wfΣ _ wf). - eapply PCUICClosedTyp.subject_closed in X0. eassumption. - eapply erases_erase; eauto. - eapply erase_wf_fixpoints. Unshelve. eauto. + eapply PCUICClosedTyp.subject_closed in X0. eassumption. + eapply erases_erase; eauto. + eapply erase_wf_fixpoints. Unshelve. eauto. Qed. Lemma erase_wellformed_weaken (efl := all_env_flags) {X_type X} decls prf univs wfΣ {Γ t} wt @@ -2032,7 +2032,7 @@ let t' := erase X_type X' Γ t wt in Proof. set (t' := erase _ _ _ _ _). cbn. epose proof (@erases_deps_erase_weaken _ X univs wfΣ decls prf Γ t wt deps). - pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. pose proof (abstract_env_ext_exists X') as [[Σ' wf']]. pose proof (abstract_env_ext_wf _ wf') as [[?]]. epose proof (erases_deps_wellformed _ H #|Γ|). @@ -2041,21 +2041,21 @@ Proof. - destruct (wt _ wf'). destruct (wfΣ _ wf). eapply PCUICClosedTyp.subject_closed in X0. eassumption. - - eapply erases_erase; eauto. + - eapply erases_erase; eauto. - eapply erase_wf_fixpoints. - Unshelve. eauto. + Unshelve. eauto. Qed. Lemma erase_constant_body_correct'' {X_type X} {cb} {decls prf} {univs wfΣ} (X' := abstract_make_wf_env_ext X univs wfΣ) -{onc : forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> ∥ on_constant_decl (lift_typing typing) Σ' cb ∥} {body} deps : +{onc : forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> ∥ on_constant_decl (lift_typing typing) Σ' cb ∥} {body} deps : EAst.cst_body (fst (erase_constant_body X_type X' cb onc)) = Some body -> - forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> + forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> ∥ ∑ t T, (Σ' ;;; [] |- t : T) * (Σ' ;;; [] |- t ⇝ℇ body) * (term_global_deps body = snd (erase_constant_body X_type X' cb onc)) * wellformed (efl:=all_env_flags) (erase_global_decls X_type (KernameSet.union deps (term_global_deps body)) X decls prf) 0 body ∥. Proof. - intros ? Σ' wfΣ'. pose proof (abstract_env_exists X) as [[Σ wf]]. + intros ? Σ' wfΣ'. pose proof (abstract_env_exists X) as [[Σ wf]]. destruct cb as [name [bod|] udecl]; simpl. simpl in H. noconf H. set (obl :=(erase_constant_body_obligation_1 X_type X' @@ -2065,11 +2065,11 @@ Proof. cst_universes := udecl |} onc bod eq_refl)). clearbody obl. destruct (obl _ wfΣ'). sq. have er : (Σ, univs);;; [] |- bod ⇝ℇ erase X_type X' [] bod obl. - { eapply (erases_erase (X:=X')). - now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + { eapply (erases_erase (X:=X')). + now rewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). } exists bod, A; intuition auto. - now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). + now rewrite (abstract_make_wf_env_ext_correct X univs wfΣ _ _ wf wfΣ'). eapply erase_wellformed_weaken. now simpl in H. Qed. @@ -2081,14 +2081,14 @@ Lemma erase_global_cst_decl_wf_glob X_type X deps decls heq : let Σ' := erase_global_decls X_type (KernameSet.union deps ecb.2) X decls heq in (@wf_global_decl all_env_flags Σ' (EAst.ConstantDecl ecb.1) : Prop). Proof. - intros cb wfΣ hcb X' ecb Σ'. + intros cb wfΣ hcb X' ecb Σ'. unfold wf_global_decl. cbn. - pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. + pose proof (abstract_env_exists X) as [[Σ wf]]. specialize_Σ wf. pose proof (abstract_env_ext_exists X') as [[Σmake wfmake]]. destruct (wfΣ _ wf), (hcb _ wfmake). red in X1. destruct EAst.cst_body eqn:hb => /= //. - eapply (erase_constant_body_correct'') in hb; eauto. - destruct hb as [[t0 [T [[] ?]]]]. rewrite e in i. exact i. + eapply (erase_constant_body_correct'') in hb; eauto. + destruct hb as [[t0 [T [[] ?]]]]. rewrite e in i. exact i. Qed. Lemma erase_global_ind_decl_wf_glob {X_type X} {deps decls kn m} heq : @@ -2120,25 +2120,25 @@ Proof. { intros. constructor. } intros. destruct a as [kn []]; simpl; destruct KernameSet.mem; set (Xpop := abstract_pop_decls X); try set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _); - epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]; + epose proof (abstract_env_exists Xpop) as [[Σpop wfpop]]; pose proof (abstract_env_wf _ wfpop) as [wfΣpop]. + constructor. eapply IHdecls => //; eauto. eapply erase_global_cst_decl_wf_glob; auto. eapply erase_global_decls_fresh; auto. destruct wfΣ. destruct wfΣpop. rewrite (heq _ wf) in o0. depelim o0. now destruct o3. - + cbn. eapply IHdecls; eauto. - + constructor. eapply IHdecls; eauto. - destruct wfΣ as [[onu ond]]. - rewrite (heq _ wf) in o. depelim o. destruct o0. + + cbn. eapply IHdecls; eauto. + + constructor. eapply IHdecls; eauto. + destruct wfΣ as [[onu ond]]. + rewrite (heq _ wf) in o. depelim o. destruct o0. eapply (erase_global_ind_decl_wf_glob (kn:=kn)); tea. - intros. rewrite (abstract_env_irr _ H wfpop). + intros. rewrite (abstract_env_irr _ H wfpop). unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf wfpop) as [? ?]. {intros; now eexists. } destruct Σpop, Σ; cbn in *. now subst. eapply erase_global_decls_fresh. destruct wfΣ as [[onu ond]]. - rewrite (heq _ wf) in o. depelim o. now destruct o0. - + eapply IHdecls; eauto. + rewrite (heq _ wf) in o. depelim o. now destruct o0. + + eapply IHdecls; eauto. Qed. Lemma lookup_erase_global (cf := config.extraction_checker_flags) {X_type X} {deps deps' decls prf} : @@ -2147,10 +2147,10 @@ Lemma lookup_erase_global (cf := config.extraction_checker_flags) {X_type X} {de Proof. revert deps deps' X prf. induction decls. cbn => //. - intros ? ? ? ? sub. - epose proof (abstract_env_exists X) as [[Σ wf]]. + intros ? ? ? ? sub. + epose proof (abstract_env_exists X) as [[Σ wf]]. destruct a as [kn' []]; cbn; - ( set (decl := E.ConstantDecl _) || + ( set (decl := E.ConstantDecl _) || set (decl := E.InductiveDecl _)); hidebody decl; set (eg := erase_global_decls _ _ _ _ _); hidebody eg; set (eg' := erase_global_decls _ _ _ _ _); hidebody eg'; @@ -2158,20 +2158,20 @@ Proof. try (set (eg''' := erase_global_decls _ _ _ _ _); hidebody eg'''). { destruct (KernameSet.mem) eqn:knm => /=. + eapply KernameSet.mem_spec, sub, KernameSet.mem_spec in knm. rewrite knm. - apply EExtends.global_subset_cons. eapply IHdecls; eauto. + apply EExtends.global_subset_cons. eapply IHdecls; eauto. intros x hin. eapply KernameSet.union_spec in hin. eapply KernameSet.union_spec. destruct hin. left. now eapply sub. right => //. + destruct (KernameSet.mem kn' deps') eqn:eq'. - eapply EExtends.global_subset_cons_right; eauto. + eapply EExtends.global_subset_cons_right; eauto. eapply erase_global_decls_wf_glob. unfold decl. unfold hidebody. constructor. eapply erase_global_decls_wf_glob. - eapply erase_global_cst_decl_wf_glob. + eapply erase_global_cst_decl_wf_glob. eapply erase_global_decls_fresh => //. pose proof (abstract_env_wf _ wf) as [wfΣ]. - depelim wfΣ. rewrite (prf _ wf) in o0. clear - o0. depelim o0. now destruct o. - unfold eg', eg'', hidebody. + depelim wfΣ. rewrite (prf _ wf) in o0. clear - o0. depelim o0. now destruct o. + unfold eg', eg'', hidebody. erewrite erase_global_decls_irr. eapply IHdecls. intros x hin. @@ -2186,23 +2186,23 @@ Proof. pose proof (abstract_env_wf _ wf) as [wfΣ]. pose proof (prf _ wf) as prf'. eapply (erase_global_ind_decl_wf_glob (kn:=kn')). - intros. + intros. unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf H) as [? [? ?]]. { now eexists. } destruct Σ, Σ0. cbn in *. rewrite prf' in wfΣ. - depelim wfΣ. cbn in *. rewrite <- H1, H0, <- H2. - depelim o0. now destruct o1. + depelim wfΣ. cbn in *. rewrite <- H1, H0, <- H2. + depelim o0. now destruct o1. eapply erase_global_decls_fresh => //. pose proof (abstract_env_wf _ wf) as [wfΣ]. pose proof (prf _ wf) as prf'. destruct Σ. cbn in *. rewrite prf' in wfΣ. - clear -wfΣ. destruct wfΣ. cbn in *. depelim o0. now destruct o1. + clear -wfΣ. destruct wfΣ. cbn in *. depelim o0. now destruct o1. unfold eg'', hidebody. erewrite erase_global_decls_irr. eapply IHdecls. intros x hin. now eapply sub. eapply IHdecls => //. } Qed. -Lemma expanded_weakening_global X_type X deps deps' decls prf Γ t : +Lemma expanded_weakening_global X_type X deps deps' decls prf Γ t : KernameSet.Subset deps deps' -> expanded (erase_global_decls X_type deps X decls prf) Γ t -> expanded (erase_global_decls X_type deps' X decls prf) Γ t. @@ -2217,7 +2217,7 @@ Proof. eapply lookup_erase_global in H; tea. Qed. -Lemma expanded_erase (cf := config.extraction_checker_flags) +Lemma expanded_erase (cf := config.extraction_checker_flags) {X_type X decls prf} univs wfΣ t wtp : forall Σ : global_env, abstract_env_rel X Σ -> PCUICEtaExpand.expanded Σ [] t -> let X' := abstract_make_wf_env_ext X univs wfΣ in @@ -2232,24 +2232,24 @@ Proof. eapply (erases_erase (X := X')); eauto. now erewrite <- (abstract_make_wf_env_ext_correct X univs wfΣ). cbn. - eapply (erases_deps_erase (X := X) univs wfΣ); eauto. + eapply (erases_deps_erase (X := X) univs wfΣ); eauto. Qed. -Lemma expanded_erase_global (cf := config.extraction_checker_flags) +Lemma expanded_erase_global (cf := config.extraction_checker_flags) deps {X_type X decls prf} : - forall Σ : global_env, abstract_env_rel X Σ -> + forall Σ : global_env, abstract_env_rel X Σ -> PCUICEtaExpand.expanded_global_env Σ -> expanded_global_env (erase_global_decls X_type deps X decls prf). Proof. intros Σ wf etaΣ. pose proof (prf _ wf). - destruct Σ as [univ decls']. - red. revert wf. red in etaΣ. cbn in *. subst. + destruct Σ as [univ decls']. + red. revert wf. red in etaΣ. cbn in *. subst. revert deps X prf. induction etaΣ; intros deps. intros. constructor. intros. - pose proof (abstract_env_exists (abstract_pop_decls X)) as [[Σpop wfpop]]. + pose proof (abstract_env_exists (abstract_pop_decls X)) as [[Σpop wfpop]]. unshelve epose proof (abstract_pop_decls_correct X Σ _ _ _ wf wfpop) as [? [? ?]]. { now eexists. } - destruct Σpop. cbn in H0, H1, H2. subst. + destruct Σpop. cbn in H0, H1, H2. subst. destruct decl as [kn []]; destruct (KernameSet.mem kn deps) eqn:eqkn; simpl; rewrite eqkn. constructor; [eapply IHetaΣ; auto|]. @@ -2259,16 +2259,16 @@ Proof. destruct H. destruct c as [cst_na [cst_body|] cst_type cst_rel]. cbn in *. - eapply expanded_weakening_global. + eapply expanded_weakening_global. 2:{ eapply expanded_erase; tea. } set (et := erase _ _ _ _) in *. - unfold deps'. unfold hidebody. intros x hin. + unfold deps'. unfold hidebody. intros x hin. eapply KernameSet.union_spec. right => //. now cbn. - eapply IHetaΣ; eauto. - constructor. eapply IHetaΣ; eauto. + eapply IHetaΣ; eauto. + constructor. eapply IHetaΣ; eauto. red. cbn => //. - eapply IHetaΣ; eauto. + eapply IHetaΣ; eauto. Qed. (* Sanity checks: the [erase] function maximally erases terms *) @@ -2281,15 +2281,15 @@ Proof. eapply Is_type_eval_inv; eauto. eexists; eauto. Qed. -Lemma erase_eval_to_box (wfl := Ee.default_wcbv_flags) +Lemma erase_eval_to_box (wfl := Ee.default_wcbv_flags) {X_type X} {univs wfext t v Σ' t' deps decls prf} : let Xext := abstract_make_wf_env_ext X univs wfext in forall wt : forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> welltyped Σ [] t, erase X_type Xext [] t wt = t' -> KernameSet.subset (term_global_deps t') deps -> erase_global_decls X_type deps X decls prf = Σ' -> - forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> - (forall Σ : global_env, abstract_env_rel X Σ -> + forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> + (forall Σ : global_env, abstract_env_rel X Σ -> PCUICWcbvEval.eval Σ t v) -> @Ee.eval Ee.default_wcbv_flags Σ' t' E.tBox -> ∥ isErasable Σext [] t ∥. Proof. @@ -2300,20 +2300,20 @@ Proof. pose proof (abstract_env_exists X) as [[? wf]]. destruct (wfext _ wf). destruct (wt _ H2) as [T wt']. pose proof (abstract_env_ext_wf _ H2) as [?]. - eapply erasable_tBox_value; eauto. - pose proof (abstract_make_wf_env_ext_correct X univs wfext _ _ wf H2). subst. - apply X0; eauto. + eapply erasable_tBox_value; eauto. + pose proof (abstract_make_wf_env_ext_correct X univs wfext _ _ wf H2). subst. + apply X0; eauto. Qed. -Lemma erase_eval_to_box_eager (wfl := Ee.default_wcbv_flags) +Lemma erase_eval_to_box_eager (wfl := Ee.default_wcbv_flags) {X_type X} {univs wfext t v Σ' t' deps decls prf} : let Xext := abstract_make_wf_env_ext X univs wfext in forall wt : forall Σ : global_env_ext, abstract_env_ext_rel Xext Σ -> welltyped Σ [] t, erase X_type Xext [] t wt = t' -> KernameSet.subset (term_global_deps t') deps -> erase_global_decls X_type deps X decls prf = Σ' -> - forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> - (forall Σ : global_env, abstract_env_rel X Σ -> + forall Σext : global_env_ext, abstract_env_ext_rel Xext Σext -> + (forall Σ : global_env, abstract_env_rel X Σ -> PCUICWcbvEval.eval Σ t v) -> @Ee.eval Ee.default_wcbv_flags Σ' t' E.tBox -> t' = E.tBox. Proof. @@ -2326,8 +2326,8 @@ Proof. simp erase => //. - elimtype False. pose proof (abstract_env_exists X) as [[? wf]]. - destruct (@is_erasableP X_type Xext [] t wt) => //. apply n. - intros. sq. now rewrite (abstract_env_ext_irr _ H H2). + destruct (@is_erasableP X_type Xext [] t wt) => //. apply n. + intros. sq. now rewrite (abstract_env_ext_irr _ H H2). Qed. From MetaCoq Require Import PCUICFirstorder. @@ -2341,10 +2341,10 @@ Proof. induction t0 in f |- *; econstructor; eauto; econstructor; eauto. Qed. -Lemma firstorder_erases_deterministic X_type (X : X_type.π1) +Lemma firstorder_erases_deterministic X_type (X : X_type.π1) univs wfext {t t' i u args mind} : let Xext := abstract_make_wf_env_ext X univs wfext in - forall wt : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t), + forall wt : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t), forall Σ, Σ ∼_ext Xext -> Σ ;;; [] |- t : mkApps (tInd i u) args -> PCUICWcbvEval.value Σ t -> @@ -2354,7 +2354,7 @@ Lemma firstorder_erases_deterministic X_type (X : X_type.π1) t' = erase X_type Xext [] t wt. Proof. (* pose proof (referenced_impl_ext_wf (@wf_env_ext_referenced extraction_checker_flags Σ)) as Hext. *) - (* rename X into Hext. *) + (* rename X into Hext. *) intros Xext wt Σ Hrel Hty Hvalue Hdecl Hfo Herase. assert (Hext : ∥ wf_ext Σ∥) by now eapply heΣ. sq. eapply firstorder_value_spec in Hty as Hfov; eauto. @@ -2366,26 +2366,26 @@ Proof. rewrite erase_mkApps. - intros Σ0 HΣ0. pose proof (abstract_env_ext_irr _ HΣ0 Hrel). subst. eapply PCUICValidity.inversion_mkApps in X0 as (? & XX & Happ). - clear XX. revert Happ. clear. generalize (mkApps (tInd i u) pandi). induction 1. + clear XX. revert Happ. clear. generalize (mkApps (tInd i u) pandi). induction 1. + econstructor. + econstructor. econstructor; eauto. eauto. - intros. eapply erases_mkApps_inv in Herase as [(? & ? & ? & -> & [Herasable] & ? & ? & ->)|(? & ? & -> & ? & ?)]. all:eauto. - + exfalso. eapply isErasable_Propositional in Herasable; eauto. + + exfalso. eapply isErasable_Propositional in Herasable; eauto. red in H1, Herasable. unfold PCUICAst.lookup_inductive, PCUICAst.lookup_minductive, isPropositionalArity in *. - edestruct PCUICEnvironment.lookup_env as [ [] | ], nth_error, destArity as [[] | ]; auto; try congruence. + edestruct PCUICEnvironment.lookup_env as [ [] | ], nth_error, destArity as [[] | ]; auto; try congruence. + inv H2. * cbn. unfold erase_clause_1. destruct (inspect_bool (is_erasableb X_type Xext [] (tConstruct i n ui) Hyp0)). - -- exfalso. sq. destruct (@is_erasableP _ _ [] (tConstruct i n ui) Hyp0) => //. + -- exfalso. sq. destruct (@is_erasableP _ _ [] (tConstruct i n ui) Hyp0) => //. specialize_Σ Hrel. sq. - eapply (isErasable_Propositional (args := [])) in s; eauto. + eapply (isErasable_Propositional (args := [])) in s; eauto. red in H1, s. unfold PCUICAst.lookup_inductive, PCUICAst.lookup_minductive, isPropositionalArity in *. edestruct PCUICEnvironment.lookup_env as [ [] | ], nth_error, destArity as [[] | ]; auto; congruence. -- f_equal. eapply Forall2_eq. clear X0 H wt. induction H3. - ++ cbn. econstructor. + ++ cbn. econstructor. ++ cbn. econstructor. ** inv H0. eapply H5. eauto. ** inv H0. eapply IHForall2. eauto. - * exfalso. eapply (isErasable_Propositional (args := [])) in X1; eauto. + * exfalso. eapply (isErasable_Propositional (args := [])) in X1; eauto. red in H1, X1. unfold PCUICAst.lookup_inductive, PCUICAst.lookup_minductive, isPropositionalArity in *. edestruct PCUICEnvironment.lookup_env as [ [] | ], nth_error, destArity as [[] | ]; auto; congruence. @@ -2401,17 +2401,17 @@ Proof. specialize_Σ H2. eapply welltyped_mkApps_inv in wt; eauto. eapply wt. now sq. Unshelve. all: try exact False. -Qed. +Qed. From MetaCoq Require Import PCUICProgress. -Lemma erase_correct_strong' (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) +Lemma erase_correct_strong' (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) univs wfext {t v Σ' t' deps i u args mind} decls prf : let Xext := abstract_make_wf_env_ext X univs wfext in -forall wt : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t), +forall wt : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t), forall Σ, abstract_env_ext_rel Xext Σ -> axiom_free Σ -> - Σ ;;; [] |- t : mkApps (tInd i u) args -> + Σ ;;; [] |- t : mkApps (tInd i u) args -> PCUICEnvironment.lookup_env Σ (i.(inductive_mind)) = Some (InductiveDecl mind) -> @firstorder_ind Σ (firstorder_env Σ) i -> erase X_type Xext [] t wt = t' -> @@ -2424,21 +2424,21 @@ Proof. intros Xext wt Σ Hrel Hax Hty Hdecl Hfo <- Hsub <- Hred Hirred wt'. pose proof (heΣ _ _ _ Hrel) as [Hwf]. eapply wcbv_standardization in Hty as Hty_; eauto. destruct Hty_ as [Heval]. edestruct (erase_correct X_type X univs wfext t v) as [v' [H1 H2]]; eauto. - 1:{ intros ? H_. sq. enough (Σ0 = Σ) as -> by eauto. + 1:{ intros ? H_. sq. enough (Σ0 = Σ) as -> by eauto. pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ H_ Hrel). now subst. } eapply firstorder_erases_deterministic in H1; eauto. + rewrite H1 in H2. eapply H2. + eapply subject_reduction; eauto. + eapply PCUICWcbvEval.eval_to_value. eauto. -Qed. +Qed. -Lemma erase_correct_strong (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) +Lemma erase_correct_strong (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) univs wfext {t v Σ' t' deps i u args mind} decls prf : let Xext := abstract_make_wf_env_ext X univs wfext in -forall wt : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t), +forall wt : (forall Σ, Σ ∼_ext Xext -> welltyped Σ [] t), forall Σ, abstract_env_ext_rel Xext Σ -> axiom_free Σ -> - Σ ;;; [] |- t : mkApps (tInd i u) args -> + Σ ;;; [] |- t : mkApps (tInd i u) args -> PCUICEnvironment.lookup_env Σ (i.(inductive_mind)) = Some (InductiveDecl mind) -> @firstorder_ind Σ (firstorder_env Σ) i -> erase X_type Xext [] t wt = t' -> @@ -2453,13 +2453,13 @@ Proof. - abstract (intros Σ_ H_; pose proof (heΣ _ _ _ H_); sq; pose proof (abstract_env_ext_irr _ H_ Hrel); subst; eapply red_welltyped; eauto; econstructor; eauto). - eapply erase_correct_strong'; eauto. -Qed. +Qed. Section EraseGlobalFast. Import PCUICEnvironment. -Definition decls_prefix decls (Σ' : global_env) := +Definition decls_prefix decls (Σ' : global_env) := ∑ Σ'', declarations Σ' = Σ'' ++ decls. Lemma on_global_decls_prefix {cf} Pcmp P univs retro decls decls' : @@ -2471,7 +2471,7 @@ Proof. now apply IHdecls. Qed. -Lemma decls_prefix_wf {decls Σ} : +Lemma decls_prefix_wf {decls Σ} : decls_prefix decls Σ -> wf Σ -> wf {| universes := Σ.(universes); declarations := decls; retroknowledge := Σ.(retroknowledge) |}. Proof. intros [Σ' hd] wfΣ. @@ -2487,24 +2487,24 @@ Qed. Lemma weaken_prefix {decls Σ kn decl} : decls_prefix decls Σ -> - wf Σ -> + wf Σ -> lookup_env {| universes := Σ; declarations := decls; retroknowledge := Σ.(retroknowledge) |} kn = Some decl -> on_global_decl cumulSpec0 (lift_typing typing) (Σ, universes_decl_of_decl decl) kn decl. Proof. intros prefix wfΣ. have wfdecls := decls_prefix_wf prefix wfΣ. - epose proof (weakening_env_lookup_on_global_env (lift_typing typing) _ Σ kn decl + epose proof (weakening_env_lookup_on_global_env (lift_typing typing) _ Σ kn decl weaken_env_prop_typing wfdecls wfΣ). forward X. red; split => //. cbn. apply incl_cs_refl. cbn. apply Retroknowledge.extends_refl. now apply (X wfdecls). Qed. -(* This version of global environment erasure keeps the same global environment throughout the whole +(* This version of global environment erasure keeps the same global environment throughout the whole erasure, while folding over the list of declarations. *) -Program Fixpoint erase_global_decls_fast (deps : KernameSet.t) - X_type (X:X_type.π1) (decls : global_declarations) +Program Fixpoint erase_global_decls_fast (deps : KernameSet.t) + X_type (X:X_type.π1) (decls : global_declarations) (prop : forall Σ : global_env, abstract_env_rel X Σ -> ∥ decls_prefix decls Σ ∥) : E.global_declarations := match decls with | [] => [] @@ -2527,10 +2527,10 @@ Program Fixpoint erase_global_decls_fast (deps : KernameSet.t) end. Next Obligation. pose proof (abstract_env_wf _ H) as [?]. - specialize_Σ H. sq. split. cbn. apply X3. cbn. + specialize_Σ H. sq. split. cbn. apply X3. cbn. eapply decls_prefix_wf in X3; tea. - destruct X3 as [onu ond]. cbn in ond. - depelim ond. now destruct o. + destruct X3 as [onu ond]. cbn in ond. + depelim ond. now destruct o. Qed. Next Obligation. pose proof (abstract_env_ext_wf _ H) as [?]. @@ -2539,7 +2539,7 @@ Next Obligation. pose proof (prop' := prop _ wf). sq. eapply (weaken_prefix (kn := kn)) in prop'; tea. 2:{ cbn. rewrite eqb_refl //. } - epose proof (abstract_make_wf_env_ext_correct X (cst_universes cb) _ _ _ wf H). subst. + epose proof (abstract_make_wf_env_ext_correct X (cst_universes cb) _ _ _ wf H). subst. apply prop'. Qed. Next Obligation. @@ -2561,7 +2561,7 @@ Qed. Import PCUICAst PCUICEnvironment. -Lemma wf_lookup Σ kn d suffix g : +Lemma wf_lookup Σ kn d suffix g : wf Σ -> declarations Σ = suffix ++ (kn, d) :: g -> lookup_env Σ kn = Some d. @@ -2580,10 +2580,10 @@ Qed. Definition add_suffix suffix Σ := set_declarations Σ (suffix ++ Σ.(declarations)). -Lemma add_suffix_cons d suffix Σ : add_suffix (d :: suffix) Σ = add_global_decl (add_suffix suffix Σ) d. +Lemma add_suffix_cons d suffix Σ : add_suffix (d :: suffix) Σ = add_global_decl (add_suffix suffix Σ) d. Proof. reflexivity. Qed. -Lemma global_erased_with_deps_weaken_prefix suffix Σ Σ' kn : +Lemma global_erased_with_deps_weaken_prefix suffix Σ Σ' kn : wf (add_suffix suffix Σ) -> global_erased_with_deps Σ Σ' kn -> global_erased_with_deps (add_suffix suffix Σ) Σ' kn. @@ -2598,10 +2598,10 @@ Proof. Qed. -(* Using weakening it is trivial to show that a term found to be erasable in Σ +(* Using weakening it is trivial to show that a term found to be erasable in Σ will be found erasable in any well-formed extension. The converse is not so trivial: some valid types in the extension are not valid in the restricted global context. - So, we will rather show that the erasure function is invariant under extension. *) + So, we will rather show that the erasure function is invariant under extension. *) Lemma isErasable_irrel_global_env {Σ Σ' : global_env_ext} {Γ t} : wf Σ -> @@ -2622,7 +2622,7 @@ Proof. eapply (env_prop_typing weakening_env (Σ', decl)) => //=. eapply extends_decls_wf; tea. now eapply extends_decls_extends. -Qed. +Qed. Definition reduce_stack_eq {cf} {fl} {X_type : abstract_env_impl} {X : X_type.π2.π1} Γ t π wi : reduce_stack fl X_type X Γ t π wi = ` (reduce_stack_full fl X_type X Γ t π wi). Proof. @@ -2636,7 +2636,7 @@ Definition same_principal_type {cf} p.π1 = p'.π1. Definition Hlookup {cf} (X_type : abstract_env_impl) (X : X_type.π2.π1) - (X_type' : abstract_env_impl) (X' : X_type'.π2.π1) := + (X_type' : abstract_env_impl) (X' : X_type'.π2.π1) := forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> forall kn decl decl', @@ -2646,8 +2646,8 @@ Definition Hlookup {cf} (X_type : abstract_env_impl) (X : X_type.π2.π1) (*Lemma erase_global_deps_suffix {deps} {Σ Σ' : wf_env} {decls hprefix hprefix'} : wf Σ -> wf Σ' -> - universes Σ = universes Σ' -> - erase_global_decls_fast deps Σ decls hprefix = + universes Σ = universes Σ' -> + erase_global_decls_fast deps Σ decls hprefix = erase_global_decls_fast deps Σ' decls hprefix'. Proof. intros wfΣ wfΣ' equ. @@ -2692,24 +2692,24 @@ Proof. destruct KernameSet.mem => //. f_equal. eapply IHdecls. Qed.*) - -Lemma erase_global_deps_fast_spec_gen {deps} + +Lemma erase_global_deps_fast_spec_gen {deps} {X_type X X'} {decls hprefix hprefix'} : - (forall Σ Σ', abstract_env_rel X Σ -> abstract_env_rel X' Σ' -> universes Σ = universes Σ' /\ retroknowledge Σ = retroknowledge Σ') -> - erase_global_decls_fast deps X_type X decls hprefix = + (forall Σ Σ', abstract_env_rel X Σ -> abstract_env_rel X' Σ' -> universes Σ = universes Σ' /\ retroknowledge Σ = retroknowledge Σ') -> + erase_global_decls_fast deps X_type X decls hprefix = erase_global_decls X_type deps X' decls hprefix'. Proof. intros equ. induction decls in X, X', equ, deps, hprefix, hprefix' |- * => //. - pose proof (abstract_env_exists X) as [[Σ wfΣ]]. + pose proof (abstract_env_exists X) as [[Σ wfΣ]]. pose proof (abstract_env_exists X') as [[Σ' wfΣ']]. - pose proof (abstract_env_wf _ wfΣ) as [wf]. + pose proof (abstract_env_wf _ wfΣ) as [wf]. pose proof (abstract_env_exists (abstract_pop_decls X')) as [[? wfpop]]. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' wfpop) as [? [? ?]]. { now eexists. } destruct a as [kn []]. - - cbn. + - cbn. set (obl := (erase_global_decls_fast_obligation_1 X_type X ((kn, ConstantDecl c) :: decls) hprefix kn c decls eq_refl)). set (eb := erase_constant_body _ _ _ _). @@ -2721,8 +2721,8 @@ Proof. intros. epose proof (abstract_make_wf_env_ext_correct X (cst_universes c) _ _ _ wfΣ H2). epose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X') (cst_universes c) _ _ _ wfpop H3). - subst. split => //. - sq; red. cbn. + subst. split => //. + sq; red. cbn. rewrite eq. rewrite <- H0, <- H1. split. symmetry. apply equ; eauto. eexists (Σ'' ++ [(kn, ConstantDecl c)]). subst. now rewrite -app_assoc. subst. symmetry. now apply equ. @@ -2731,8 +2731,8 @@ Proof. intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. - { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. - + { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. + - cbn. destruct KernameSet.mem => //; f_equal; eapply IHdecls. intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. @@ -2744,30 +2744,30 @@ Proof. Qed. Lemma erase_global_deps_fast_spec {deps} {X_type X} {decls hprefix hprefix'} : - erase_global_decls_fast deps X_type X decls hprefix = + erase_global_decls_fast deps X_type X decls hprefix = erase_global_decls X_type deps X decls hprefix'. Proof. eapply erase_global_deps_fast_spec_gen; intros. - rewrite (abstract_env_irr _ H H0); eauto. + rewrite (abstract_env_irr _ H H0); eauto. Qed. Definition erase_global_fast X_type deps X decls (prf:forall Σ : global_env, abstract_env_rel X Σ -> declarations Σ = decls) := erase_global_decls_fast deps X_type X decls (fun _ H => sq ([] ; prf _ H)). -Lemma expanded_erase_global_fast (cf := config.extraction_checker_flags) deps +Lemma expanded_erase_global_fast (cf := config.extraction_checker_flags) deps {X_type X decls prf} : - forall Σ : global_env, abstract_env_rel X Σ -> + forall Σ : global_env, abstract_env_rel X Σ -> PCUICEtaExpand.expanded_global_env Σ -> expanded_global_env (erase_global_fast X_type deps X decls prf). Proof. unfold erase_global_fast. - rewrite erase_global_deps_fast_spec. + rewrite erase_global_deps_fast_spec. eapply expanded_erase_global. Qed. -Lemma expanded_erase_fast (cf := config.extraction_checker_flags) +Lemma expanded_erase_fast (cf := config.extraction_checker_flags) {X_type X decls prf} univs wfΣ t wtp : - forall Σ : global_env, abstract_env_rel X Σ -> + forall Σ : global_env, abstract_env_rel X Σ -> PCUICEtaExpand.expanded Σ [] t -> let X' := abstract_make_wf_env_ext X univs wfΣ in let et := (erase X_type X' [] t wtp) in @@ -2776,11 +2776,11 @@ Lemma expanded_erase_fast (cf := config.extraction_checker_flags) Proof. intros Σ wf hexp X'. pose proof (abstract_env_wf _ wf) as [?]. eapply (expanded_erases (Σ := (Σ, univs))); tea. - eapply (erases_erase (X := X')). + eapply (erases_erase (X := X')). pose proof (abstract_env_ext_exists X') as [[? wfmake]]. now rewrite <- (abstract_make_wf_env_ext_correct X univs _ _ _ wf wfmake). cbn. unfold erase_global_fast. rewrite erase_global_deps_fast_spec //. - eapply (erases_deps_erase (X := X) univs wfΣ); eauto. + eapply (erases_deps_erase (X := X) univs wfΣ); eauto. Qed. Lemma erase_global_fast_wf_glob X_type X deps decls prf : @@ -2790,13 +2790,13 @@ Proof. eapply erase_global_decls_wf_glob. Qed. -Lemma erase_wellformed_fast (efl := all_env_flags) +Lemma erase_wellformed_fast (efl := all_env_flags) {X_type X decls prf} univs wfΣ {Γ t} wt (X' := abstract_make_wf_env_ext X univs wfΣ) : let t' := erase X_type X' Γ t wt in wellformed (erase_global_fast X_type (term_global_deps t') X decls prf) #|Γ| t'. Proof. - intros. + intros. cbn. unfold erase_global_fast. rewrite erase_global_deps_fast_spec. eapply erase_wellformed. Qed. diff --git a/erasure/theories/ErasureProperties.v b/erasure/theories/ErasureProperties.v index 96e5d25b0..d7fe8e5de 100644 --- a/erasure/theories/ErasureProperties.v +++ b/erasure/theories/ErasureProperties.v @@ -147,7 +147,7 @@ Lemma is_ConstructApp_erases Σ Γ t t' : negb (isConstructApp t) -> negb (EAstUtils.isConstructApp t'). Proof. induction 1; cbn; try congruence. - unfold isConstructApp in *. clear IHerases2. - cbn. rewrite head_tapp. + cbn. rewrite head_tapp. unfold EAstUtils.isConstructApp in *. cbn. now rewrite EAstUtils.head_tApp. Qed. @@ -157,7 +157,7 @@ Lemma is_PrimApp_erases Σ Γ t t' : negb (isPrimApp t) -> negb (EAstUtils.isPrimApp t'). Proof. induction 1; cbn; try congruence. - unfold isPrimApp in *. clear IHerases2. - cbn. rewrite head_tapp. + cbn. rewrite head_tapp. unfold EAstUtils.isPrimApp in *. cbn. now rewrite EAstUtils.head_tApp. Qed. @@ -241,7 +241,7 @@ Proof. + subst types. eapply conv_context_app_same; auto. + eapply conv_context_wf_local_app; eauto. - + assumption. + + assumption. - econstructor. eapply All2_impl. eapply All2_All_mix_left. eassumption. eassumption. @@ -330,7 +330,7 @@ Proof. intros ? ? [] [] (? & ? & (? & ?) & (? & ?)) (? & ?). split. 2: now cbn in *. cbn -[app_context] in *. fold (subst_instance u bbody). - eapply erases_ext_eq. + eapply erases_ext_eq. 2, 4, 5: reflexivity. eapply e; eauto. + eapply typing_subst_instance_wf_local; eauto. destruct Σ; eassumption. @@ -344,7 +344,7 @@ Proof. eapply (All_impl X0); pcuicfo. now destruct X5 as [s [Hs ?]]; exists s. eapply All_mfix_wf in X5; auto. subst types. - + revert X5. clear - wfΣ wfΓ H2 X2 X3. induction 1. - eauto. @@ -380,7 +380,7 @@ Proof. eapply (All_impl X0); pcuicfo. destruct X5 as [s [Hs ?]]; now exists s. eapply All_mfix_wf in X5; auto. subst types. - + revert X5. clear - wfΣ wfΓ H2 X2 X3. induction 1. - eauto. @@ -460,7 +460,7 @@ Proof. intros cla era. revert Γ e era Heq. pattern Γl, a. - match goal with + match goal with |- ?P Γl a => simpl; eapply (term_closedn_list_ind P); auto; clear end; simpl; intros; subst k; match goal with [H:erases _ _ _ _ |- _] => depelim H end; trivial; @@ -470,7 +470,7 @@ Proof. eapply All_forallb. unfold tCaseBrsProp_k in X0. eapply All2_All_mix_left in X1; eauto. close_Forall. intros [] []. cbn in *. intros. - solve_all. subst. rewrite map_length. eapply b0. eauto. + solve_all. subst. rewrite map_length. eapply b0. eauto. rewrite app_context_length. cbn. now rewrite inst_case_branch_context_length. - epose proof (All2_length X0). @@ -489,14 +489,14 @@ Qed. Section wellscoped. Import PCUICAst PCUICGlobalEnv. - - Definition lookup_constant Σ kn := + + Definition lookup_constant Σ kn := match PCUICEnvironment.lookup_env Σ kn with | Some (ConstantDecl d) => Some d | _ => None end. Import MCMonadNotation. - + Section Def. Context (Σ : global_env). Import ssrbool. @@ -509,11 +509,11 @@ Section wellscoped. | tLambda _ N M => wellformed N && wellformed M | tApp u v => wellformed u && wellformed v | tLetIn na b ty b' => wellformed b && wellformed ty && wellformed b' - | tCase ind p c brs => + | tCase ind p c brs => let brs' := forallb (wellformed ∘ bbody) brs in isSome (lookup_inductive Σ ind.(ci_ind)) && wellformed c && brs' | tProj p c => isSome (lookup_projection Σ p) && wellformed c - | tFix mfix idx => + | tFix mfix idx => (idx (isLambda b) && wellformed b)) mfix | tCoFix mfix idx => @@ -557,7 +557,7 @@ Section wellscoped. Proof. intros []. eapply typing_wellformed; tea. Qed. - + End wellscoped. Import EWellformed. @@ -606,8 +606,8 @@ Section trans_lookups. now destruct nth_error => //. Qed. - Lemma trans_lookup_projection p : - isSome (lookup_projection Σ p) -> + Lemma trans_lookup_projection p : + isSome (lookup_projection Σ p) -> isSome (EGlobalEnv.lookup_projection Σ' p). Proof using g. destruct g. @@ -629,7 +629,7 @@ Section trans_lookups. End trans_lookups. -Lemma erases_wellformed {Σ : global_env_ext} {wfΣ : wf Σ} {Γ a e} : welltyped Σ Γ a -> Σ ;;; Γ |- a ⇝ℇ e -> +Lemma erases_wellformed {Σ : global_env_ext} {wfΣ : wf Σ} {Γ a e} : welltyped Σ Γ a -> Σ ;;; Γ |- a ⇝ℇ e -> forall Σ', globals_erased_with_deps Σ Σ' -> @EWellformed.wellformed EWellformed.all_env_flags Σ' #|Γ| e. Proof. intros wf. @@ -639,7 +639,7 @@ Proof. intros cla wfa era. revert Γ e wfa era Heq. pattern Γl, a. - match goal with + match goal with |- ?P Γl a => simpl; eapply (term_closedn_list_ind P); auto; clear end; simpl; intros; subst k; match goal with [H:erases _ _ _ _ |- _] => depelim H end; trivial; @@ -655,14 +655,14 @@ Proof. eapply forallb_All in wfbrs. eapply All2_All_mix_left in X1; eauto. close_Forall. intros [] []; move=> [] wf. cbn in *. intros. - solve_all. subst. rewrite map_length. eapply b; eauto. + solve_all. subst. rewrite map_length. eapply b; eauto. rewrite app_context_length. cbn. now rewrite inst_case_branch_context_length. - move/andP: wfa => [] hl hc. - apply/andP; split. + apply/andP; split. now eapply trans_lookup_projection in hl. eauto. - - epose proof (All2_length X0). + - epose proof (All2_length X0). unfold EWellformed.wf_fix_gen. rewrite -H0. move/andP: wfa => [] ->. move/forallb_All. cbn. intros wfa. @@ -687,7 +687,7 @@ Qed. Lemma eval_empty_brs {wfl : Ee.WcbvFlags} Σ ci p e : Σ ⊢ E.tCase ci p [] ▷ e -> False. Proof. intros He. - depind He. + depind He. - clear -e2. now rewrite nth_error_nil in e2. - clear -e2. now rewrite nth_error_nil in e2. - discriminate. @@ -695,17 +695,17 @@ Proof. - cbn in i. discriminate. Qed. -Lemma eval_case_tBox_inv {wfl : Ee.WcbvFlags} {Σ ci e brs} : - Σ ⊢ E.tCase ci EAst.tBox brs ▷ e -> - ∑ n br, brs = [(n, br)] × inductive_isprop_and_pars Σ ci.1 = Some (true, ci.2) × +Lemma eval_case_tBox_inv {wfl : Ee.WcbvFlags} {Σ ci e brs} : + Σ ⊢ E.tCase ci EAst.tBox brs ▷ e -> + ∑ n br, brs = [(n, br)] × inductive_isprop_and_pars Σ ci.1 = Some (true, ci.2) × Σ ⊢ ECSubst.substl (repeat EAst.tBox #|n|) br ▷ e. Proof. intros He. - depind He. + depind He. - depelim He1. clear -H. symmetry in H. elimtype False. destruct args using rev_case. discriminate. rewrite EAstUtils.mkApps_app in H. discriminate. - - depelim He1. + - depelim He1. - exists n, f4. intuition auto. - depelim He1. clear -H. symmetry in H. elimtype False. destruct args using rev_case. discriminate. @@ -713,13 +713,13 @@ Proof. - cbn in i. discriminate. Qed. -Lemma eval_case_eval_discr {wfl : Ee.WcbvFlags} {Σ ci c c' e brs} : - Σ ⊢ E.tCase ci c brs ▷ e -> +Lemma eval_case_eval_discr {wfl : Ee.WcbvFlags} {Σ ci c c' e brs} : + Σ ⊢ E.tCase ci c brs ▷ e -> Σ ⊢ c ▷ c' -> Σ ⊢ E.tCase ci c' brs ▷ e. Proof. intros He Hc. - depind He. + depind He. - pose proof (Ee.eval_deterministic He1 Hc). subst c'. econstructor; eauto. now eapply Ee.value_final, Ee.eval_to_value. - pose proof (Ee.eval_deterministic He1 Hc). subst c'. @@ -732,13 +732,13 @@ Proof. - cbn in i. discriminate. Qed. -Lemma eval_case_eval_inv_discr {wfl : Ee.WcbvFlags} {Σ ci c c' e brs} : - Σ ⊢ E.tCase ci c brs ▷ e -> +Lemma eval_case_eval_inv_discr {wfl : Ee.WcbvFlags} {Σ ci c c' e brs} : + Σ ⊢ E.tCase ci c brs ▷ e -> Σ ⊢ c' ▷ c -> Σ ⊢ E.tCase ci c' brs ▷ e. Proof. intros He Hc. - depind He. + depind He. - pose proof (eval_trans' Hc He1); subst discr. econstructor; eauto. - pose proof (eval_trans' Hc He1); subst discr. @@ -750,8 +750,8 @@ Proof. - cbn in i. discriminate. Qed. -Lemma eval_proj_eval_inv_discr {wfl : Ee.WcbvFlags} {Σ p c c' e} : - Σ ⊢ E.tProj p c ▷ e -> +Lemma eval_proj_eval_inv_discr {wfl : Ee.WcbvFlags} {Σ p c c' e} : + Σ ⊢ E.tProj p c ▷ e -> Σ ⊢ c' ▷ c -> Σ ⊢ E.tProj p c' ▷ e. Proof. @@ -760,11 +760,11 @@ Proof. - pose proof (eval_trans' Hc He1); subst discr. econstructor; eauto. - pose proof (eval_trans' Hc He1); subst discr. - now econstructor; tea. + now econstructor; tea. - pose proof (eval_trans' Hc He1); subst discr. - now econstructor; tea. + now econstructor; tea. - pose proof (eval_trans' Hc He); subst discr. - now econstructor; tea. + now econstructor; tea. - cbn in i. discriminate. Qed. diff --git a/erasure/theories/Extract.v b/erasure/theories/Extract.v index 1a02b412e..e49fa683d 100644 --- a/erasure/theories/Extract.v +++ b/erasure/theories/Extract.v @@ -9,7 +9,7 @@ Module E := EAst. Local Existing Instance extraction_checker_flags. -Definition isErasable Σ Γ t := ∑ T, Σ ;;; Γ |- t : T × (isArity T + (∑ u, (Σ ;;; Γ |- T : tSort u) * +Definition isErasable Σ Γ t := ∑ T, Σ ;;; Γ |- t : T × (isArity T + (∑ u, (Σ ;;; Γ |- T : tSort u) * is_propositional u))%type. Definition isPropositionalArity ar b := @@ -18,7 +18,7 @@ Definition isPropositionalArity ar b := | None => False end. -Definition isPropositional Σ ind b := +Definition isPropositional Σ ind b := match lookup_inductive Σ ind with | Some (mdecl, idecl) => isPropositionalArity idecl.(ind_type) b | _ => False @@ -40,7 +40,7 @@ Definition erase_prim_model {t : prim_tag} (e : @prim_model term t) : @prim_mode | primIntModel i => primIntModel i | primFloatModel f => primFloatModel f end. - + Definition erase_prim_val (p : prim_val term) : prim_val E.term := (p.π1; erase_prim_model p.π2). @@ -94,7 +94,7 @@ Inductive erases (Σ : global_env_ext) (Γ : context) : term -> E.term -> Prop : dbody d ⇝ℇ E.dbody d') mfix mfix' -> Σ;;; Γ |- tCoFix mfix n ⇝ℇ E.tCoFix mfix' n | erases_tPrim : forall p, Σ;;; Γ |- tPrim p ⇝ℇ E.tPrim (erase_prim_val p) - | erases_box : forall t : term, isErasable Σ Γ t -> Σ;;; Γ |- t ⇝ℇ E.tBox + | erases_box : forall t : term, isErasable Σ Γ t -> Σ;;; Γ |- t ⇝ℇ E.tBox where "Σ ;;; Γ |- s ⇝ℇ t" := (erases Σ Γ s t). Lemma erases_forall_list_ind @@ -129,7 +129,7 @@ Lemma erases_forall_list_ind PCUICElimination.Informative Σ ci.(ci_ind) -> Σ;;; Γ |- c ⇝ℇ c' -> P Γ c c' -> - All2 (fun x x' => Σ;;; Γ ,,, inst_case_branch_context p x |- bbody x ⇝ℇ x'.2 × + All2 (fun x x' => Σ;;; Γ ,,, inst_case_branch_context p x |- bbody x ⇝ℇ x'.2 × erase_context (bcontext x) = x'.1) brs brs' -> Forall2 (fun br br' => P (Γ ,,, inst_case_branch_context p br) (bbody br) br'.2) brs brs' -> P Γ (tCase ci p c brs) (E.tCase (ci.(ci_ind), ci.(ci_npar)) c' brs')) @@ -218,7 +218,7 @@ Definition erases_one_inductive_body (oib : one_inductive_body) (oib' : E.one_in Forall2 (fun cdecl cstr => cdecl.(PCUICEnvironment.cstr_arity) = cstr.(E.cstr_nargs) /\ cdecl.(cstr_name) = cstr.(E.cstr_name)) oib.(ind_ctors) oib'.(E.ind_ctors) /\ Forall2 (fun 'i i' => i.(PCUICEnvironment.proj_name) = i'.(E.proj_name)) oib.(ind_projs) oib'.(E.ind_projs) /\ oib'.(E.ind_name) = oib.(ind_name) /\ - oib'.(E.ind_kelim) = oib.(ind_kelim) /\ + oib'.(E.ind_kelim) = oib.(ind_kelim) /\ isPropositionalArity oib.(ind_type) oib'.(E.ind_propositional). Definition erases_mutual_inductive_body (mib : mutual_inductive_body) (mib' : E.mutual_inductive_body) := @@ -337,4 +337,4 @@ Definition computational_ind Σ ind := Definition computational_type Σ T := exists ind, inductive_arity T = Some ind /\ computational_ind Σ ind. - + diff --git a/erasure/theories/Prelim.v b/erasure/theories/Prelim.v index 7166b4341..bac94b50d 100644 --- a/erasure/theories/Prelim.v +++ b/erasure/theories/Prelim.v @@ -38,9 +38,9 @@ Proof. Qed. Lemma typing_spine_eval: - forall (Σ : global_env_ext) (args args' : list PCUICAst.term) + forall (Σ : global_env_ext) (args args' : list PCUICAst.term) (X : All2 (PCUICWcbvEval.eval Σ) args args') (bla : wf Σ) - (T x x0 : PCUICAst.term) (t0 : typing_spine Σ [] x args x0) + (T x x0 : PCUICAst.term) (t0 : typing_spine Σ [] x args x0) (c : Σ;;; [] ⊢ x0 ≤ T) (x1 : PCUICAst.term) (c0 : Σ;;; [] ⊢ x1 ≤ x), isType Σ [] x1 -> isType Σ [] T -> typing_spine Σ [] x1 args' T. Proof. @@ -243,7 +243,7 @@ Lemma declared_constructor_assumption_context (wfl := default_wcbv_flags) {Σ c Proof. intros. destruct (on_declared_constructor H) as [? [cu [_ onc]]]. - destruct onc. + destruct onc. now eapply is_assumption_context_spec. Qed. @@ -259,10 +259,10 @@ Qed. Lemma expand_lets_erasure (wfl := default_wcbv_flags) {Σ mdecl idecl cdecl c brs p} {wfΣ : wf_ext Σ} : declared_constructor Σ c mdecl idecl cdecl -> wf_branches idecl brs -> - All2i (fun i cdecl br => + All2i (fun i cdecl br => All2 (PCUICEquality.compare_decls eq eq) (bcontext br) (cstr_branch_context c.1 mdecl cdecl)) 0 idecl.(ind_ctors) brs -> - All (fun br => + All (fun br => expand_lets (inst_case_branch_context p br) (bbody br) = bbody br) brs. Proof. intros decl wfbrs. @@ -283,15 +283,15 @@ Proof. eapply (assumption_context_cstr_branch_context (c:=(i0, i))). split. apply decl. tea. Qed. -Lemma assumption_context_compare_decls Γ Δ : +Lemma assumption_context_compare_decls Γ Δ : PCUICEquality.eq_context_upto_names Γ Δ -> assumption_context Γ -> assumption_context Δ. Proof. induction 1; auto. - intros H; depelim H. + intros H; depelim H. depelim r; econstructor; auto. -Qed. +Qed. Lemma smash_assumption_context Γ Δ : assumption_context Γ -> smash_context Δ Γ = Γ ,,, Δ. @@ -306,8 +306,8 @@ Proof. Qed. Import PCUICGlobalEnv PCUICSpine. -Lemma subslet_cstr_branch_context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} - {Γ pars parsubst parsubst' s' inst' ind n mdecl idecl cdecl u p br napp} : +Lemma subslet_cstr_branch_context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} + {Γ pars parsubst parsubst' s' inst' ind n mdecl idecl cdecl u p br napp} : declared_constructor Σ (ind, n) mdecl idecl cdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> consistent_instance_ext Σ (ind_universes mdecl) (puinst p) -> @@ -318,7 +318,7 @@ Lemma subslet_cstr_branch_context {cf : checker_flags} {Σ : global_env_ext} {wf ws_cumul_pb_terms Σ Γ pars (pparams p) -> wf_predicate mdecl idecl p -> wf_branch cdecl br -> - PCUICSpine.spine_subst Σ Γ s' inst' + PCUICSpine.spine_subst Σ Γ s' inst' (subst_context parsubst 0 (subst_context (inds (inductive_mind ind) u (ind_bodies mdecl)) #|ind_params mdecl| (cstr_args cdecl)@[u])) -> subslet Σ Γ (List.rev s') (case_branch_context ind mdecl p (forget_types (bcontext br)) cdecl). Proof. @@ -335,7 +335,7 @@ Proof. cbn in eqctx. epose proof (spine_subst_smash spargs). eapply spine_subst_cumul in X. eapply X. - pcuic. pcuic. apply X. + pcuic. pcuic. apply X. { eapply substitution_wf_local. eapply (spine_subst_smash sppars'). eapply PCUICInductives.wf_local_expand_lets. rewrite -app_context_assoc. diff --git a/examples/constructor_tac.v b/examples/constructor_tac.v index 31f58df31..0777cf86a 100644 --- a/examples/constructor_tac.v +++ b/examples/constructor_tac.v @@ -3,7 +3,7 @@ From MetaCoq.Template Require Import All Loader. Import MCMonadNotation. Open Scope bs. -Definition constructor (goal : Ast.term): TemplateMonad typed_term := +Definition constructor (goal : Ast.term): TemplateMonad typed_term := let '(hd, iargs) := decompose_app goal in match hd with | Ast.tInd ind u => @@ -13,7 +13,7 @@ Definition constructor (goal : Ast.term): TemplateMonad typed_term := let cstrs := Ast.Env.ind_ctors oib in match cstrs with | [] => tmFail "no constructor in this inductive type" - | hd :: _ => + | hd :: _ => let args := cstr_args hd in let params := firstn qi.(ind_npars) iargs in let args := (params ++ map (fun _ => Ast.hole) args)%list in @@ -28,7 +28,7 @@ Definition constructor (goal : Ast.term): TemplateMonad typed_term := Ltac constructor_tac := match goal with - |- ?T => + |- ?T => let k tm := refine tm.(my_projT2) in unshelve quote_term T ltac:(fun gl => run_template_program (constructor gl) k) end. diff --git a/examples/demo.v b/examples/demo.v index c05d427f4..227ff7792 100644 --- a/examples/demo.v +++ b/examples/demo.v @@ -149,7 +149,7 @@ Definition one_list_i : one_inductive_entry := mind_entry_typename := "demoList"; mind_entry_arity := tSort Universe.type0; mind_entry_consnames := ["demoNil"; "demoCons"]; - mind_entry_lc := [tApp (tRel 1) [tRel 0]; + mind_entry_lc := [tApp (tRel 1) [tRel 0]; mkImpl (tRel 0) (mkImpl (tApp (tRel 2) [tRel 1]) (tApp (tRel 3) [tRel 2]))]; |}. @@ -306,7 +306,7 @@ MetaCoq Run (tmUnquoteTyped (nat -> nat -> nat) add_syntax >>= tmPrint). -Inductive NonRec (A:Set) (C: A -> Set): Set := +Inductive NonRec (A:Set) (C: A -> Set): Set := | SS : forall (f:A), C f -> NonRec A C. MetaCoq Run (printInductive "NonRec"). @@ -319,7 +319,7 @@ Polymorphic Definition Funtp@{i} (A B: Type@{i}) := A->B. (* Locate Funtm. *) (* MetaCoq Run (printConstant "Top.Funtm"). *) -Polymorphic Definition Funtp2@{i j} +Polymorphic Definition Funtp2@{i j} (A: Type@{i}) (B: Type@{j}) := A->B. (* MetaCoq Run (printConstant "Top.demo.Funtp2"). *) (* TODOO *) diff --git a/examples/metacoq_tour.v b/examples/metacoq_tour.v index 7c2fc10b8..56a098c66 100644 --- a/examples/metacoq_tour.v +++ b/examples/metacoq_tour.v @@ -5,14 +5,14 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICReduction PCUICCumulativity PCUI Import MCMonadNotation. Local Open Scope bs_scope. -(** MetaCoq is: +(** MetaCoq is: - - The "template-coq" monad, dealing with reification of terms + - The "template-coq" monad, dealing with reification of terms and environments. - The PCUIC development of the syntactic metatheory of Coq. - - The SafeChecker package implementing reduction, conversion + - The SafeChecker package implementing reduction, conversion and typechecking in a sound and complete way. - - The Erasure package implementing verified extraction to + - The Erasure package implementing verified extraction to untyped lambda-calculus *) @@ -25,7 +25,7 @@ MetaCoq Quote Definition reifx := (fun x : nat => x). Definition foo := (fun x : nat => fun x : nat => x). MetaCoq Quote Definition reifx' := Eval compute in (fun x : nat => let y := x in fun x : nat => y). Print reifx'. -MetaCoq Unquote Definition x := +MetaCoq Unquote Definition x := (Ast.tConstruct (mkInd (MPfile ["Datatypes"; "Init"; "Coq"], "nat") 0) 0 []). MetaCoq Run (tmBind (tmQuote (3 + 3)) tmPrint). @@ -39,7 +39,7 @@ Next Obligation. Defined. (* PCUIC: - + + Universes (with full algebraic universes supported everywhere) + Universe polymorphism + Standard type theory with dependent products and let-ins @@ -65,8 +65,8 @@ Check PCUICSafeConversion.isconv_term_complete. Check PCUICSafeChecker.infer_wf_env. (** Proof of completeness is near completion. *) -(** Verified retyping: from a term that is known to be well-typeable, - compute its principal type. Very common in tactics to avoid retypechecking +(** Verified retyping: from a term that is known to be well-typeable, + compute its principal type. Very common in tactics to avoid retypechecking the whole term. *) Check type_of. Check type_of_subtype. @@ -77,7 +77,7 @@ From MetaCoq.Examples Require Import metacoq_tour_prelude. Check check_inh. (** We construct a proof of typing entirely within Coq, calling the typechecker to produce the derivation *) -(* Lemma identity_typing (u := Universe.make univ): +(* Lemma identity_typing (u := Universe.make univ): inh gctx_wf_env [] (tProd (bNamed "s") (tSort u) (tImpl (tRel 0) (tRel 0))). Proof. (* We construct a term *) @@ -102,7 +102,7 @@ MetaCoq Quote Recursively Definition zero := 0. Definition zerocst := Eval lazy in test zero. -Definition singleton_elim := +Definition singleton_elim := ((fun (X : Set) (x : X) (e : x = x) => match e in eq _ x' return bool with | eq_refl => true @@ -113,39 +113,39 @@ MetaCoq Run (tmEval lazy singleton_elim >>= tmQuoteRec >>= MetaCoq Erase singleton_elim. -(** Conclusion: Status of MetaCoq +(** Conclusion: Status of MetaCoq - Correctness and complete typechecker for (a large fragment of) Coq. - All metatheory proofs are finished. Compared to Coq's implementation: - + - full (max (i + k, j + l)) universe support (including a naïve acyclicity checking algorithm) - + - partial support for SProp (in programs but not yet formalized typing rules) - + - approximate cumulative inductive types checking (not yet up to reduction) - - - missing eta-conversion: the plan is to use contravariant subtyping and eta-reduction, + + - missing eta-conversion: the plan is to use contravariant subtyping and eta-reduction, as in Coq CEP #47 - - - missing template-polymorphism: we're studying a sort polymorphism extension + + - missing template-polymorphism: we're studying a sort polymorphism extension (with G. Gilbert, K. Maillard and N. Tabareau) to subsume it completely. - + - missing modules and fast conversion machines. - Much work to come on the template-coq side to ease meta-programming. - Relation to CertiCoq: fast and verified correct erasure, not depending on type-checking (only retyping). - + + CertiCoq needs to have all constructors eta-expanded, a proof of the syntactic translation expanding constructors is in progress. - - + Otherwise the front-end part of CertiCoq is complete with proofs. - + + + Otherwise the front-end part of CertiCoq is complete with proofs. + + Future work: handling of primitive types (ints, floats, arrays, ...) - + *) diff --git a/examples/metacoq_tour_prelude.v b/examples/metacoq_tour_prelude.v index a9cb95f4f..23b2cd119 100644 --- a/examples/metacoq_tour_prelude.v +++ b/examples/metacoq_tour_prelude.v @@ -22,11 +22,11 @@ Definition univ := Level.Level "s". (* TODO move to SafeChecker *) -Definition gctx : global_env_ext := +Definition gctx : global_env_ext := ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), ConstraintSet.empty); declarations := []; retroknowledge := Retroknowledge.empty |}, Monomorphic_ctx). -(** We use the environment checker to produce the proof that gctx, which is a singleton with only +(** We use the environment checker to produce the proof that gctx, which is a singleton with only universe "s" declared is well-formed. *) Definition kername_of_string (s : string) : kername := @@ -34,7 +34,7 @@ Definition kername_of_string (s : string) : kername := Global Program Instance fake_guard_impl : abstract_guard_impl := {| guard_impl := fake_guard_impl |}. -Next Obligation. Admitted. +Next Obligation. Admitted. Definition make_wf_env_ext (Σ : global_env_ext) : EnvCheck wf_env_ext wf_env_ext := '(exist Σ' pf) <- check_wf_ext optimized_abstract_env_impl Σ ;; @@ -42,7 +42,7 @@ Definition make_wf_env_ext (Σ : global_env_ext) : EnvCheck wf_env_ext wf_env_ex Definition gctx_wf_env : wf_env_ext. Proof. - let wf_proof := eval hnf in (make_wf_env_ext gctx) in + let wf_proof := eval hnf in (make_wf_env_ext gctx) in match wf_proof with | CorrectDecl _ ?x => exact x | _ => fail "Couldn't prove the global environment is well-formed" @@ -55,19 +55,19 @@ Defined. Definition inh (Σ : wf_env_ext) Γ T := (∑ t, forall Σ0 : global_env_ext, abstract_env_ext_rel Σ Σ0 -> ∥ typing Σ0 Γ t T ∥). -Definition check_inh (Σ : wf_env_ext) Γ - (wfΓ : forall Σ0 : global_env_ext, abstract_env_ext_rel Σ Σ0 -> ∥ wf_local Σ0 Γ ∥) t {T} : typing_result (inh Σ Γ T) := +Definition check_inh (Σ : wf_env_ext) Γ + (wfΓ : forall Σ0 : global_env_ext, abstract_env_ext_rel Σ Σ0 -> ∥ wf_local Σ0 Γ ∥) t {T} : typing_result (inh Σ Γ T) := prf <- check_type_wf_env_fast optimized_abstract_env_impl Σ Γ wfΓ t (T := T) ;; ret (t; prf). -Ltac fill_inh t := +Ltac fill_inh t := lazymatch goal with - [ wfΓ : forall _ _ , ∥ wf_local _ ?Γ ∥ |- inh ?Σ ?Γ ?T ] => + [ wfΓ : forall _ _ , ∥ wf_local _ ?Γ ∥ |- inh ?Σ ?Γ ?T ] => let t := uconstr:(check_inh Σ Γ wfΓ t (T:=T)) in let proof := eval cbn in t in match proof with | Checked ?d => exact_no_check d - | TypeError ?e => + | TypeError ?e => let str := eval cbn in (string_of_type_error Σ e) in fail "Failed to inhabit " T " : " str | _ => fail "Anomaly: unexpected return value: " proof diff --git a/examples/tauto.v b/examples/tauto.v index d59e71a64..99e976365 100644 --- a/examples/tauto.v +++ b/examples/tauto.v @@ -567,14 +567,14 @@ Definition decl_size (size : term -> nat) (x : context_decl) := Definition context_size (size : term -> nat) (l : context) := list_size (decl_size size) l. - -Definition branch_size (size : term -> nat) (br : branch term) := + +Definition branch_size (size : term -> nat) (br : branch term) := size br.(bbody). -Definition predicate_size (size : term -> nat) (p : predicate term) := - list_size size p.(pparams) + +Definition predicate_size (size : term -> nat) (p : predicate term) := + list_size size p.(pparams) + size p.(preturn). - + Fixpoint tsize t : nat := match t with | tRel i => 1 @@ -661,8 +661,8 @@ Proof. f_equal; simpl; auto. induction a; simpl; auto. induction X0; simpl; auto. - f_equal; auto. f_equal; auto. - unfold branch_size; simpl; auto. + f_equal; auto. f_equal; auto. + unfold branch_size; simpl; auto. - generalize (#|m| + k). intro p. induction X. + reflexivity. @@ -793,7 +793,7 @@ Proof. } lia. - repeat inst. - + assert ( list_size (branch_size tsize) (map_branches_k (subst [tRel 0]) k l) <= list_size (branch_size tsize) l @@ -1017,18 +1017,18 @@ Section Plugin. Definition trivial_hyp (h:list form) v : forall h : form, In h [] -> sem h v. intro. destruct 1. - Qed. + Qed. - Transparent reify. + Transparent reify. Inductive NotSolvable (s: string) : Prop := notSolvable: NotSolvable s. Definition inhabit_formula gamma Mphi Gamma : match reify (empty_ext empty_global_env) gamma Mphi with - Some phi => - match tauto_proc (size phi) {| hyps := []; concl := phi |} with + Some phi => + match tauto_proc (size phi) {| hyps := []; concl := phi |} with Valid => sem (concl {| hyps := []; concl := phi |}) (can_val_Prop Gamma) - | _ => NotSolvable "not a valid formula" end + | _ => NotSolvable "not a valid formula" end | None => NotSolvable "not a formaula" end. destruct (reify (empty_ext _) gamma Mphi); try exact (notSolvable _). destruct (tauto_proc (size f) {| hyps := []; concl := f |}) eqn : e; try exact (notSolvable _). @@ -1048,9 +1048,9 @@ Section Plugin. end. Ltac extract_form_tac k l := - match goal with | |- forall X:Prop, _ => + match goal with | |- forall X:Prop, _ => let H := fresh "H" in - intros H; + intros H; extract_form_tac k ltac:(constr:(H::l)) | |- _ => k l end. @@ -1059,7 +1059,7 @@ Section Plugin. pose proof (let Mphi := extract_form x 0 in inhabit_formula (Prop_ctx (snd Mphi)) (fst Mphi) l) as H; compute in H in quote_term T k. - + Ltac tauto := let L := fresh "L" in let P := fresh "P" in @@ -1073,10 +1073,10 @@ Section Plugin. Lemma test : forall (A B C:Prop), (A->C)->(B->C)->A\/B->C. tauto. - Qed. + Qed. Lemma test2 : forall (A B C:Prop), (A->C)->(B->C)->A\/B->B. Fail tauto. - Abort. + Abort. End Plugin. diff --git a/examples/typing_correctness.v b/examples/typing_correctness.v index 22c5d57e4..97ce4db80 100644 --- a/examples/typing_correctness.v +++ b/examples/typing_correctness.v @@ -55,7 +55,7 @@ Local Existing Instance default_checker_flags. Definition gctx_wf_env : wf_env_ext. Proof. - let wf_proof := eval hnf in (make_wf_env_ext gctx) in + let wf_proof := eval hnf in (make_wf_env_ext gctx) in match wf_proof with | CorrectDecl _ ?x => exact x | ?z => set (error := z) @@ -87,11 +87,11 @@ Definition univ := Level.Level "s". (* TODO move to SafeChecker *) -Definition gctx : global_env_ext := +Definition gctx : global_env_ext := ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), ConstraintSet.empty); declarations := [] ; retroknowledge := Retroknowledge.empty |}, Monomorphic_ctx). -(** We use the environment checker to produce the proof that gctx, which is a singleton with only +(** We use the environment checker to produce the proof that gctx, which is a singleton with only universe "s" declared is well-formed. *) Definition kername_of_string (s : string) : kername := @@ -99,7 +99,7 @@ Definition kername_of_string (s : string) : kername := Global Program Instance fake_guard_impl : abstract_guard_impl := {| guard_impl := fake_guard_impl |}. -Next Obligation. Admitted. +Next Obligation. Admitted. Definition make_wf_env_ext (Σ : global_env_ext) : EnvCheck wf_env_ext wf_env_ext := '(exist Σ' pf) <- check_wf_ext optimized_abstract_env_impl Σ ;; @@ -107,7 +107,7 @@ Definition make_wf_env_ext (Σ : global_env_ext) : EnvCheck wf_env_ext wf_env_ex Definition gctx_wf_env : wf_env_ext. Proof. - let wf_proof := eval hnf in (make_wf_env_ext gctx) in + let wf_proof := eval hnf in (make_wf_env_ext gctx) in match wf_proof with | CorrectDecl _ ?x => exact x | _ => fail "Couldn't prove the global environment is well-formed" @@ -120,18 +120,18 @@ Defined. Definition inh {cf:checker_flags} (Σ : wf_env_ext) Γ T := ∑ t, forall Σ0 : global_env_ext, abstract_env_ext_rel Σ Σ0 -> ∥ typing Σ0 Γ t T ∥. -Definition check_inh (Σ : wf_env_ext) Γ (wfΓ : forall Σ0 : global_env_ext, abstract_env_ext_rel Σ Σ0 -> ∥ wf_local Σ0 Γ ∥) t {T} : typing_result (inh Σ Γ T) := +Definition check_inh (Σ : wf_env_ext) Γ (wfΓ : forall Σ0 : global_env_ext, abstract_env_ext_rel Σ Σ0 -> ∥ wf_local Σ0 Γ ∥) t {T} : typing_result (inh Σ Γ T) := prf <- check_type_wf_env_fast optimized_abstract_env_impl Σ Γ wfΓ t (T := T) ;; ret (t; prf). -Ltac fill_inh t := +Ltac fill_inh t := lazymatch goal with - [ wfΓ : forall _ _, ∥ wf_local _ ?Γ ∥ |- inh ?Σ ?Γ ?T ] => + [ wfΓ : forall _ _, ∥ wf_local _ ?Γ ∥ |- inh ?Σ ?Γ ?T ] => let t := uconstr:(check_inh Σ Γ wfΓ t (T:=T)) in let proof := eval cbn in t in match proof with | Checked ?d => exact_no_check d - | TypeError ?e => + | TypeError ?e => let str := eval cbn in (string_of_type_error Σ e) in fail "Failed to inhabit " T " : " str | _ => set (blocked := proof) @@ -151,7 +151,7 @@ Proof. Time Qed. *) -Lemma identity_typing (u := Universe.make univ): +Lemma identity_typing (u := Universe.make univ): (∑ t : term, forall Σ0 : global_env_ext, Σ0 = @@ -175,12 +175,12 @@ Proof. let proof := eval hnf in t in match proof with | Checked ?d => exact_no_check d - | TypeError ?e => + | TypeError ?e => let str := eval cbn in (string_of_type_error Σ e) in fail "Failed to inhabit " T " : " str | _ => set (blocked := proof) (* fail "Anomaly: unexpected return value: " proof *) end. -Defined. +Defined. (* Print Opaque Dependencies identity_typing. *) diff --git a/pcuic/theories/Bidirectional/BDFromPCUIC.v b/pcuic/theories/Bidirectional/BDFromPCUIC.v index 6d5f18112..5fed2ead2 100644 --- a/pcuic/theories/Bidirectional/BDFromPCUIC.v +++ b/pcuic/theories/Bidirectional/BDFromPCUIC.v @@ -24,7 +24,7 @@ Proof. Qed. Lemma ctx_inst_length {ty Σ Γ args Δ} : -PCUICTyping.ctx_inst ty Σ Γ args Δ -> +PCUICTyping.ctx_inst ty Σ Γ args Δ -> #|args| = context_assumptions Δ. Proof. induction 1; simpl; auto. @@ -132,14 +132,14 @@ Proof. 1: eexists. all: eassumption. + by apply conv_check in Hc. - + - intros. eexists. split. 2: by eapply typing_ws_cumul_pb ; tea ; constructor. constructor. eassumption. - + - intros. eexists. split. @@ -160,7 +160,7 @@ Proof. constructor. apply leq_universe_product_mon. all: assumption. - + - intros n A t ? ? ? ? CumA ? (?&?&?). apply conv_infer_sort in CumA ; auto. destruct CumA as (?&?&?). @@ -193,7 +193,7 @@ Proof. etransitivity ; tea. now apply ws_cumul_pb_eq_le. + now eapply substitution_ws_cumul_pb_vass. - + - intros. eexists. split. @@ -202,7 +202,7 @@ Proof. 1: fvs. rewrite on_free_vars_subst_instance. now eapply closed_on_free_vars, declared_constant_closed_type. - + - intros. eexists. split. @@ -211,7 +211,7 @@ Proof. 1: fvs. rewrite on_free_vars_subst_instance. now eapply closed_on_free_vars, declared_inductive_closed_type. - + - intros. eexists. split. @@ -219,7 +219,7 @@ Proof. apply ws_cumul_pb_refl. 1: fvs. now eapply closed_on_free_vars, declared_constructor_closed_type. - + - intros ci p c brs indices ps mdecl idecl isdecl wfΣ' wfbΓ epar ? predctx wfpred ? ? ty_p Cump ? ? Hinst ty_c Cumc ? ? ? ty_br. apply conv_infer_sort in Cump as (?&?&?) ; auto. @@ -240,7 +240,7 @@ Proof. 2: eapply on_declared_minductive ; eauto. rewrite firstn_app_left //. now destruct wfpred. - + * replace #|x1| with #|pparams p ++ indices|. 1: assumption. symmetry. @@ -257,7 +257,7 @@ Proof. context_assumptions_app -(declared_minductive_ind_npars isdecl) => alen. rewrite firstn_length_le. all: lia. - + * eapply All2i_impl. 1: eassumption. intros j cdecl br (?&Hbr). @@ -354,7 +354,7 @@ Proof. + apply (All_impl Allbodies). intros ? [? s]. by apply conv_check in s ; auto. - + - intros mfix n decl types ? ? ? Alltypes Allbodies. eexists. split. @@ -371,9 +371,9 @@ Proof. + apply (All_impl Allbodies). intros ? [? s]. by apply conv_check in s ; auto. - + - intros p prim_ty cdecl wfΓ' hp hdecl pinv. - eexists. split; [econstructor; tea|]. + eexists. split; [econstructor; tea|]. eapply ws_cumul_pb_refl; fvs. - intros ? ? ? ? ? ? (?&?&?) ? (?&?&?) ?. @@ -459,7 +459,7 @@ Proof. 1,4: now apply IHΓ'. - now apply isType_infering_sort. - now apply typing_checking. - - now apply isType_infering_sort. + - now apply isType_infering_sort. Qed. Theorem ctx_inst_typing_bd `{checker_flags} (Σ : global_env_ext) Γ l Δ (wfΣ : wf Σ) : diff --git a/pcuic/theories/Bidirectional/BDStrengthening.v b/pcuic/theories/Bidirectional/BDStrengthening.v index 9a406d9b6..2ca75690d 100644 --- a/pcuic/theories/Bidirectional/BDStrengthening.v +++ b/pcuic/theories/Bidirectional/BDStrengthening.v @@ -1,7 +1,7 @@ From Coq Require Import Bool List Arith Lia. From Coq Require String. From MetaCoq.Template Require Import config utils monad_utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICGlobalEnv +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICGlobalEnv PCUICTactics PCUICInduction PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICUtils PCUICPosition PCUICTyping PCUICSigmaCalculus PCUICOnFreeVars PCUICClosed PCUICConfluence PCUICSpine PCUICInductiveInversion PCUICParallelReductionConfluence PCUICWellScopedCumulativity PCUICClosed PCUICRenameDef PCUICInstConv PCUICClosedTyp PCUICWeakeningEnvTyp PCUICRenameTyp PCUICRenameConv PCUICGuardCondition PCUICWeakeningConv. @@ -146,16 +146,16 @@ Qed. Lemma on_free_vars_ctx_tip P d : on_free_vars_ctx P [d] = on_free_vars_decl P d. Proof. cbn; rewrite andb_true_r // shiftnP0 //. Qed. -Lemma on_free_vars_it_mkLambda_or_LetIn {P Δ t} : - on_free_vars P (it_mkLambda_or_LetIn Δ t) = +Lemma on_free_vars_it_mkLambda_or_LetIn {P Δ t} : + on_free_vars P (it_mkLambda_or_LetIn Δ t) = on_free_vars_ctx P Δ && on_free_vars (shiftnP #|Δ| P) t. Proof. move: P. induction Δ using rev_ind => P. - cbn. now rewrite shiftnP0. - destruct x as [na [b|] ty]; rewrite it_mkLambda_or_LetIn_app /= /mkLambda_or_LetIn /=. - rewrite on_free_vars_ctx_app /= IHΔ !lengths /= shiftnP_add on_free_vars_ctx_tip /= + rewrite on_free_vars_ctx_app /= IHΔ !lengths /= shiftnP_add on_free_vars_ctx_tip /= /on_free_vars_decl /test_decl /=. ring. - rewrite on_free_vars_ctx_app /= IHΔ !lengths /= shiftnP_add on_free_vars_ctx_tip /= + rewrite on_free_vars_ctx_app /= IHΔ !lengths /= shiftnP_add on_free_vars_ctx_tip /= /on_free_vars_decl /test_decl /=. ring. Qed. @@ -213,7 +213,7 @@ Proof. by rewrite /= (Nat.add_comm k n) Nat.sub_add_distr Nat.add_sub orb_diag. Qed. -Lemma on_free_vars_subst (p : nat -> bool) k s t : +Lemma on_free_vars_subst (p : nat -> bool) k s t : forallb (on_free_vars p) s -> on_free_vars (shiftnP (k + #|s|) p) t -> on_free_vars (shiftnP k p) (subst s k t). @@ -382,7 +382,7 @@ Section OnFreeVars. - constructor. - intros. red. - intros P HΓ Hn. + intros P HΓ Hn. eapply alli_Alli, Alli_nth_error in HΓ ; tea. apply on_free_vars_lift0. by move: HΓ => /implyP /(_ Hn) /andP []. @@ -434,13 +434,13 @@ Section OnFreeVars. apply /andP ; split. 2: by rewrite case_predicate_context_length. eapply on_free_vars_case_predicate_context ; eassumption. - + + rewrite forallb_app. apply /andP ; split. 2: by rewrite /= andb_true_r. apply All_forallb, All_skipn. auto. - + - intros until args. move => ? _ ? largs ? ? ?. apply on_free_vars_subst0. @@ -450,7 +450,7 @@ Section OnFreeVars. auto. + eapply closedn_on_free_vars. rewrite closedn_subst_instance /= List.rev_length largs. - eapply declared_projection_closed_type ; tea. + eapply declared_projection_closed_type ; tea. - intros until decl. move => ? ndec ? ? ? ? ? /= Hmfix. @@ -465,7 +465,7 @@ Section OnFreeVars. erewrite ndec in Hmfix. cbn in Hmfix. by move: Hmfix => /andP []. - + - easy. - easy. @@ -515,7 +515,7 @@ Lemma on_free_vars_type `{checker_flags} P Σ (wfΣ : wf Σ.1) Γ t T : ∑ T', on_free_vars P T' × Σ ;;; Γ |- t : T'. Proof. intros oΓ ot ty. - assert (wf_local Σ Γ) by (eapply typing_wf_local ; tea). + assert (wf_local Σ Γ) by (eapply typing_wf_local ; tea). apply typing_infering in ty as [T' []] ; tea. exists T' ; split. - edestruct bidirectional_on_free_vars as (_&_&_&?&_). @@ -556,7 +556,7 @@ Let Pind Γ ind t u args := on_ctx_free_vars P Γ -> on_free_vars P t -> Σ ;;; Δ |- rename f t ▹{ind} (u, map (rename f) args). - + Let Pcheck Γ t T := forall P Δ f, @@ -656,7 +656,7 @@ Proof using wfΣ. rewrite on_ctx_free_vars_concat. apply /andP ; split ; tea. by rewrite on_free_vars_ctx_on_ctx_free_vars. - + - intros Γ n decl isdecl P Δ f hf hΓ ht. eapply hf in isdecl as h => //. destruct h as [decl' [isdecl' [? [h1 h2]]]]. @@ -665,14 +665,14 @@ Proof using wfΣ. - intros. red. intros. cbn in *. by constructor. - + - intros. red. move => P Δ f hf hΓ /= /andP [] ? ?. econstructor ; eauto. eapply X2 ; tea. 1: by apply urenaming_vass. rewrite on_ctx_free_vars_snoc /=. apply /andP ; split ; tea. - + - intros. red. move => P Δ f hf hΓ /= /andP [] ? ?. econstructor ; eauto. eapply X2 ; tea. @@ -706,7 +706,7 @@ Proof using wfΣ. erewrite rename_closed. 2: by eapply declared_inductive_closed_type ; tea. econstructor ; tea. - + - intros. red. move => P Δ f hf hΓ /= _. erewrite rename_closed. 2: by eapply declared_constructor_closed_type ; tea. @@ -802,13 +802,13 @@ Proof using wfΣ. all: tea. split. all: assumption. - + - intros. red. move => P Δ f hf hΓ /= ?. rewrite rename_subst0 /= rename_subst_instance map_rev List.rev_length. erewrite rename_closedn. 2: rewrite H0 ; eapply declared_projection_closed_type ; tea. econstructor ; eauto. - by rewrite map_length. + by rewrite map_length. - intros. red. move => P Δ f hf hΓ /= /forallb_All ht. erewrite map_dtype. @@ -832,7 +832,7 @@ Proof using wfΣ. * rewrite -(Nat.add_0_r (#|mfix|)) fix_context_length. apply on_free_vars_lift_impl. by rewrite shiftnP0. - + by apply rename_wf_fixpoint. + + by apply rename_wf_fixpoint. - intros. red. move => P Δ f hf hΓ /= /forallb_All ht. erewrite map_dtype. @@ -856,11 +856,11 @@ Proof using wfΣ. * rewrite -(Nat.add_0_r (#|mfix|)) fix_context_length. apply on_free_vars_lift_impl. by rewrite shiftnP0. - + by apply rename_wf_cofixpoint. - + + by apply rename_wf_cofixpoint. + - intros. red. intros P Δ f hf ht. cbn. econstructor; tea. - + - intros. red. intros P Δ f hf ht. econstructor ; eauto. rewrite -/(rename f (tSort u)). @@ -989,7 +989,7 @@ Proof. case_inequalities. all: lia. Qed. - + Lemma strengthening `{cf: checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} Γ Γ' Γ'' t T : Σ ;;; Γ ,,, Γ' ,,, lift_context #|Γ'| 0 Γ'' |- lift #|Γ'| #|Γ''| t : T -> ∑ T', Σ ;;; Γ ,,, Γ'' |- t : T'. diff --git a/pcuic/theories/Bidirectional/BDToPCUIC.v b/pcuic/theories/Bidirectional/BDToPCUIC.v index bb53ce6a2..13cd23357 100644 --- a/pcuic/theories/Bidirectional/BDToPCUIC.v +++ b/pcuic/theories/Bidirectional/BDToPCUIC.v @@ -84,7 +84,7 @@ Proof. + apply IHΓ'. assumption. + apply infer_typing_sort_impl with id X0; intros Hs. apply weaken_ctx ; eauto. -Qed. +Qed. Lemma wf_local_local_rel `{checker_flags} Σ Γ Γ' : wf_local Σ (Γ ,,, Γ') -> wf_local_rel Σ Γ Γ'. Proof. @@ -134,7 +134,7 @@ Section BDToPCUICTyping. Lemma bd_wf_local Γ (all: wf_local_bd Σ Γ) : All_local_env_over_sorting checking infering_sort (fun Σ Γ _ t T _ => Pcheck Γ t T) - (fun Σ Γ _ t s _ => Psort Γ t s) + (fun Σ Γ _ t s _ => Psort Γ t s) Σ Γ all -> wf_local Σ Γ. Proof using Type. @@ -151,7 +151,7 @@ Section BDToPCUICTyping. (fun Σ Δ => checking Σ (Γ,,,Δ)) (fun Σ Δ => infering_sort Σ (Γ,,,Δ)) (fun Σ Δ _ t T _ => Pcheck (Γ,,,Δ) t T) - (fun Σ Δ _ t s _ => Psort (Γ,,,Δ) t s) + (fun Σ Δ _ t s _ => Psort (Γ,,,Δ) t s) Σ Γ' all -> wf_local_rel Σ Γ Γ'. Proof using Type. @@ -164,7 +164,7 @@ Section BDToPCUICTyping. all: now apply Hs, wf_local_app. Qed. - Lemma ctx_inst_impl Γ (wfΓ : wf_local Σ Γ) (Δ : context) (wfΔ : wf_local_rel Σ Γ (List.rev Δ)) : + Lemma ctx_inst_impl Γ (wfΓ : wf_local Σ Γ) (Δ : context) (wfΔ : wf_local_rel Σ Γ (List.rev Δ)) : forall args, PCUICTyping.ctx_inst (fun _ => Pcheck) Σ Γ args Δ -> ctx_inst Σ Γ args Δ. Proof using wfΣ. revert wfΔ. @@ -209,7 +209,7 @@ Section BDToPCUICTyping. cbn in wfΔ |- *. eassumption. Qed. - + (** The big theorem, proven by mutual induction using the custom induction principle *) Theorem bidirectional_to_pcuic : env_prop_bd Σ Pcheck Pinfer Psort Pprod Pind PΓ PΓ_rel. Proof using wfΣ. @@ -232,16 +232,16 @@ Section BDToPCUICTyping. apply X2. constructor. 1: by auto. eexists. eauto. - + - red ; intros ; econstructor ; eauto. + apply X2 ; auto. eexists. eauto. - + + apply X4. constructor ; auto. * eexists. eauto. * apply X2 ; auto. eexists. eauto. - + - red ; intros. eapply type_App' ; auto. apply X2 ; auto. @@ -301,7 +301,7 @@ Section BDToPCUICTyping. 1: eapply validity ; auto. now rewrite H0. } - + assert (isType Σ Γ (mkApps (tInd ci (puinst p)) (pparams p ++ skipn (ci_npar ci) args))) as [? tyapp]. { @@ -324,7 +324,7 @@ Section BDToPCUICTyping. eapply wf_case_predicate_context ; tea. eexists ; tea. } - + econstructor ; eauto. 2-3: split ; eauto. 1: now eapply type_Cumul ; eauto ; apply cumulAlgo_cumulSpec in cum. @@ -344,7 +344,7 @@ Section BDToPCUICTyping. apply Hbody ; auto. eexists. eassumption. - + - red ; intros ; econstructor ; eauto. - red ; intros ; econstructor ; eauto. @@ -429,9 +429,9 @@ Section BDToPCUICTyping. destruct X3. econstructor ; eauto. eapply (cumulAlgo_cumulSpec _ (pb := Cumul)), into_ws_cumul_pb ; tea. - + fvs. + + fvs. + now eapply type_is_open_term. - + now eapply subject_is_open_term. + + now eapply subject_is_open_term. Qed. End BDToPCUICTyping. diff --git a/pcuic/theories/Bidirectional/BDTyping.v b/pcuic/theories/Bidirectional/BDTyping.v index 3ed6180ca..4a874047e 100644 --- a/pcuic/theories/Bidirectional/BDTyping.v +++ b/pcuic/theories/Bidirectional/BDTyping.v @@ -69,7 +69,7 @@ Inductive infering `{checker_flags} (Σ : global_env_ext) (Γ : context) : term consistent_instance_ext Σ (ind_universes mdecl) u -> Σ ;;; Γ |- tConstruct ind i u ▹ type_of_constructor mdecl cdecl (ind, i) u -| infer_Case ci p c brs args u ps mdecl idecl : +| infer_Case ci p c brs args u ps mdecl idecl : let predctx := case_predicate_context ci.(ci_ind) mdecl idecl p in let ptm := it_mkLambda_or_LetIn predctx p.(preturn) in Σ ;;; Γ |- c ▹{ci} (u,args) -> @@ -109,7 +109,7 @@ Inductive infering `{checker_flags} (Σ : global_env_ext) (Γ : context) : term nth_error mfix n = Some decl -> All (fun d => {s & Σ ;;; Γ |- d.(dtype) ▹□ s}) mfix -> All (fun d => Σ ;;; Γ ,,, fix_context mfix |- d.(dbody) ◃ lift0 #|fix_context mfix| d.(dtype)) mfix -> - wf_fixpoint Σ mfix -> + wf_fixpoint Σ mfix -> Σ ;;; Γ |- tFix mfix n ▹ dtype decl | infer_CoFix mfix n decl : @@ -142,7 +142,7 @@ with infering_indu `{checker_flags} (Σ : global_env_ext) (Γ : context) : induc | infer_ind_Ind ind t T u args: Σ ;;; Γ |- t ▹ T -> red Σ Γ T (mkApps (tInd ind u) args) -> - Σ ;;; Γ |- t ▹{ind} (u,args) + Σ ;;; Γ |- t ▹{ind} (u,args) with checking `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> term -> Type := | check_Cumul t T T': @@ -164,7 +164,7 @@ Definition tybranches {cf} Σ Γ ci mdecl idecl p ptm n ctors brs := (fun (i : nat) (cdecl : constructor_body) (br : branch term) => (eq_context_upto_names br.(bcontext) (cstr_branch_context ci mdecl cdecl)) × let brctxty := case_branch_type ci mdecl idecl p br ptm i cdecl in - (wf_local_bd_rel Σ Γ brctxty.1) × + (wf_local_bd_rel Σ Γ brctxty.1) × Σ;;; Γ,,, brctxty.1 |- bbody br ◃ brctxty.2) n ctors brs. @@ -174,8 +174,8 @@ Definition branches_size {cf} {Σ Γ ci mdecl idecl p ptm brs} {n ctors} (a : tybranches Σ Γ ci mdecl idecl p ptm n ctors brs) : size := - (all2i_size _ (fun i cdecl br p => - (Nat.max + (all2i_size _ (fun i cdecl br p => + (Nat.max (All_local_rel_sorting_size checking_size infering_size _ _ _ p.2.1) (checking_size _ _ _ _ p.2.2))) a). @@ -191,7 +191,7 @@ Proof. | H : infering _ _ _ _ |- _ => apply infering_size in H | H : infering_sort _ _ _ _ |- _ => apply infering_sort_size in H | H : infering_prod _ _ _ _ _ _ |- _ => apply infering_prod_size in H - | H : infering_indu _ _ _ _ _ _ |- _ => apply infering_indu_size in H + | H : infering_indu _ _ _ _ _ _ |- _ => apply infering_indu_size in H | H : checking _ _ _ _ |- _ => apply checking_size in H | H : wf_local_bd _ _ |- _ => apply (All_local_env_sorting_size _ _ (checking_size _) (infering_sort_size _) _ _) in H | H : wf_local_bd_rel _ _ _ |- _ => apply (All_local_rel_sorting_size (checking_size _) (infering_sort_size _) _ _) in H @@ -320,10 +320,10 @@ Section BidirectionalInduction. let Pdecl_check_rel Γ := fun _ Δ _ t T _ => Pcheck (Γ,,,Δ) t T in let Pdecl_sort_rel Γ := fun _ Δ _ t u _ => Psort (Γ,,,Δ) t u in - (forall (Γ : context) (wfΓ : wf_local_bd Σ Γ), + (forall (Γ : context) (wfΓ : wf_local_bd Σ Γ), All_local_env_over_sorting checking infering_sort Pdecl_check Pdecl_sort Σ Γ wfΓ -> PΓ Γ) -> - (forall (Γ Γ' : context) (wfΓ' : wf_local_bd_rel Σ Γ Γ'), + (forall (Γ Γ' : context) (wfΓ' : wf_local_bd_rel Σ Γ Γ'), All_local_env_over_sorting (fun Σ Δ => checking Σ (Γ,,,Δ)) (fun Σ Δ => infering_sort Σ (Γ,,,Δ)) (Pdecl_check_rel Γ) (Pdecl_sort_rel Γ) Σ Γ' wfΓ' -> PΓ_rel Γ Γ') -> (forall (Γ : context) (n : nat) decl, @@ -434,7 +434,7 @@ Section BidirectionalInduction. Pcheck (Γ ,,, fix_context mfix) d.(dbody) (lift0 #|fix_context mfix| d.(dtype))) mfix -> wf_fixpoint Σ mfix -> Pinfer Γ (tFix mfix n) (dtype decl)) -> - + (forall (Γ : context) (mfix : mfixpoint term) (n : nat) decl, cofix_guard Σ Γ mfix -> nth_error mfix n = Some decl -> @@ -474,7 +474,7 @@ Section BidirectionalInduction. Pinfer Γ t T -> Σ ;;; Γ |- T <= T' -> Pcheck Γ t T') -> - + env_prop_bd. Proof using Type. intros Pdecl_check Pdecl_sort Pdecl_check_rel Pdecl_sort_rel HΓ HΓRel HRel HSort HProd HLambda HLetIn HApp HConst HInd HConstruct HCase @@ -485,7 +485,7 @@ Section BidirectionalInduction. enough (HP : forall x : typing_sum, Ptyping_sum x). - repeat split ; intros. + exact (HP (context_cons Γ X)). - + exact (HP (context_rel_cons Γ Γ' X)). + + exact (HP (context_rel_cons Γ Γ' X)). + exact (HP (check_cons Γ T t X)). + exact (HP (inf_cons Γ T t X)). + exact (HP (sort_cons Γ t u X)). @@ -498,7 +498,7 @@ Section BidirectionalInduction. intros d IH. destruct d ; simpl. 4: destruct i. - + - eapply HΓ. dependent induction wfΓ. + constructor. @@ -559,7 +559,7 @@ Section BidirectionalInduction. - unshelve eapply HProd ; auto. all: applyIH. - + - unshelve eapply HLambda ; auto. all: applyIH. @@ -596,7 +596,7 @@ Section BidirectionalInduction. intros. apply IH. cbn -[Nat.max]. - lia. + lia. + cbn in IH. clear - IH a2. @@ -615,7 +615,7 @@ Section BidirectionalInduction. apply IH. simpl. lia. - + - unshelve eapply HProj ; auto. all: applyIH. @@ -680,7 +680,7 @@ Section BidirectionalInduction. cbn. lia. - unshelve eapply HPrim; eauto. - + - destruct i. unshelve (eapply HiSort ; try eassumption) ; try eassumption. all:applyIH. diff --git a/pcuic/theories/Bidirectional/BDUnique.v b/pcuic/theories/Bidirectional/BDUnique.v index c58ee1d3d..58cf52558 100644 --- a/pcuic/theories/Bidirectional/BDUnique.v +++ b/pcuic/theories/Bidirectional/BDUnique.v @@ -30,7 +30,7 @@ Let Psort Γ t u := Let Pprod Γ t (na : aname) A B := wf_local Σ Γ -> forall na' A' B', Σ ;;; Γ |- t ▹Π (na',A',B') -> - ∑ A'' B'', + ∑ A'' B'', [× na = na', Σ ;;; Γ ⊢ A ⇝ A'', Σ ;;; Γ ⊢ A' ⇝ A'', Σ ;;; Γ,, vass na A ⊢ B ⇝ B'' & Σ ;;; Γ,, vass na A' ⊢ B' ⇝ B'']. @@ -121,14 +121,14 @@ Proof using wfΣ. 1,3: fvs. all: rewrite on_free_vars_subst_instance. all: now eapply closed_on_free_vars, declared_inductive_closed_type. - + - replace cdecl0 with cdecl by (eapply declared_constructor_inj ; eassumption). replace mdecl0 with mdecl by (eapply declared_constructor_inj ; eassumption). eexists ; split. all: eapply closed_red_refl. 1,3: fvs. all: now eapply closed_on_free_vars, declared_constructor_closed_type. - + - eapply declared_projection_inj in H as (?&?&?&?); tea. subst. move: (X2) => tyc'. @@ -176,7 +176,7 @@ Proof using wfΣ. cbn in H. len. rewrite closedn_on_free_vars //. eapply closed_upwards; tea. cbn. lia. - + - rewrite H3 in H0 ; injection H0 as ->. eapply nth_error_all in X as (?&[]); tea. eexists ; split. @@ -190,7 +190,7 @@ Proof using wfΣ. all: eapply closed_red_refl. 1,3:fvs. all: now eapply subject_is_open_term, infering_sort_typing. - + - intros ? T' ty_T'. inversion ty_T' ; subst. move: (H) => /declared_inductive_inj /(_ H13) [? ?]. @@ -262,7 +262,7 @@ Proof using wfΣ. constructor. 1: eapply closed_red_ctx_refl ; fvs. now constructor. - + - inversion X3 ; subst. eapply X0 in X4 as [T'' []]; subst ; tea. eapply into_closed_red in X1 ; fvs. @@ -324,7 +324,7 @@ Qed. Theorem infering_sort_infering `{checker_flags} {Σ} (wfΣ : wf Σ) {Γ} {wfΓ : wf_local Σ Γ} {t u T} : - Σ ;;; Γ |- t ▹□ u -> Σ ;;; Γ |- t ▹ T -> + Σ ;;; Γ |- t ▹□ u -> Σ ;;; Γ |- t ▹ T -> Σ ;;; Γ ⊢ T ⇝ tSort u. Proof. intros ty ty'. @@ -341,7 +341,7 @@ Qed. Theorem infering_prod_prod `{checker_flags} {Σ} (wfΣ : wf Σ) {Γ} (wfΓ : wf_local Σ Γ) {t na na' A A' B B'} : Σ ;;; Γ |- t ▹Π (na,A,B) -> Σ ;;; Γ |- t ▹Π (na',A',B') -> - ∑ A'' B'', + ∑ A'' B'', [× na = na', Σ ;;; Γ ⊢ A ⇝ A'', Σ ;;; Γ ⊢ A' ⇝ A'', Σ ;;; Γ,, vass na A ⊢ B ⇝ B'' & Σ ;;; Γ,, vass na A' ⊢ B' ⇝ B'']. Proof. diff --git a/pcuic/theories/Conversion/PCUICClosedConv.v b/pcuic/theories/Conversion/PCUICClosedConv.v index 3ecc6004c..73e7c7067 100644 --- a/pcuic/theories/Conversion/PCUICClosedConv.v +++ b/pcuic/theories/Conversion/PCUICClosedConv.v @@ -1,8 +1,8 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import Morphisms. +From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction - PCUICLiftSubst PCUICUnivSubst PCUICSigmaCalculus PCUICClosed + PCUICLiftSubst PCUICUnivSubst PCUICSigmaCalculus PCUICClosed PCUICOnFreeVars PCUICTyping PCUICReduction PCUICGlobalEnv PCUICWeakeningEnv PCUICEquality. @@ -11,7 +11,7 @@ From Equations Require Import Equations. Implicit Types (cf : checker_flags) (Σ : global_env_ext). -Lemma type_local_ctx_All_local_env {cf} P Σ Γ Δ s : +Lemma type_local_ctx_All_local_env {cf} P Σ Γ Δ s : All_local_env (lift_typing P Σ) Γ -> type_local_ctx (lift_typing P) Σ Γ Δ s -> All_local_env (lift_typing P Σ) (Γ ,,, Δ). @@ -22,7 +22,7 @@ Proof. exists s; auto. Qed. -Lemma sorts_local_ctx_All_local_env {cf} P Σ Γ Δ s : +Lemma sorts_local_ctx_All_local_env {cf} P Σ Γ Δ s : All_local_env (lift_typing P Σ) Γ -> sorts_local_ctx (lift_typing P) Σ Γ Δ s -> All_local_env (lift_typing P Σ) (Γ ,,, Δ). @@ -38,7 +38,7 @@ Lemma type_local_ctx_Pclosed Σ Γ Δ s : type_local_ctx (lift_typing Pclosed) Σ Γ Δ s -> Alli (fun i d => closed_decl (#|Γ| + i) d) 0 (List.rev Δ). Proof. - induction Δ; simpl; auto; try constructor. + induction Δ; simpl; auto; try constructor. destruct a as [? [] ?]; intuition auto. - apply Alli_app_inv; auto. constructor. simpl. rewrite List.rev_length. 2:constructor. @@ -55,7 +55,7 @@ Lemma sorts_local_ctx_Pclosed Σ Γ Δ s : sorts_local_ctx (lift_typing Pclosed) Σ Γ Δ s -> Alli (fun i d => closed_decl (#|Γ| + i) d) 0 (List.rev Δ). Proof. - induction Δ in s |- *; simpl; auto; try constructor. + induction Δ in s |- *; simpl; auto; try constructor. destruct a as [? [] ?]; intuition auto. - apply Alli_app_inv; eauto. constructor. simpl. rewrite List.rev_length. 2:constructor. @@ -73,7 +73,7 @@ Lemma All_local_env_Pclosed Σ Γ : All_local_env ( lift_typing Pclosed Σ) Γ -> Alli (fun i d => closed_decl i d) 0 (List.rev Γ). Proof. - induction Γ; simpl; auto; try constructor. + induction Γ; simpl; auto; try constructor. intros all; depelim all; intuition auto. - apply Alli_app_inv; auto. constructor. simpl. rewrite List.rev_length. 2:constructor. @@ -85,13 +85,13 @@ Proof. now simpl. Qed. -Lemma weaken_env_prop_closed {cf} : +Lemma weaken_env_prop_closed {cf} : weaken_env_prop cumulSpec0 (lift_typing typing) (lift_typing (fun (_ : global_env_ext) (Γ : context) (t T : term) => closedn #|Γ| t && closedn #|Γ| T)). Proof. repeat red. intros. destruct t; red in X0; eauto. Qed. -Lemma closedn_ctx_alpha {k ctx ctx'} : +Lemma closedn_ctx_alpha {k ctx ctx'} : eq_context_upto_names ctx ctx' -> closedn_ctx k ctx = closedn_ctx k ctx'. Proof. @@ -102,7 +102,7 @@ Proof. Qed. Lemma closedn_All_local_env (ctx : list context_decl) : - All_local_env + All_local_env (fun (Γ : context) (b : term) (t : typ_or_sort) => closedn #|Γ| b && typ_or_sort_default (closedn #|Γ|) t true) ctx -> closedn_ctx 0 ctx. @@ -127,7 +127,7 @@ Proof. - simpl. eauto. Qed. -Lemma closed_cstr_branch_context_gen {cf : checker_flags} {Σ} {wfΣ : wf Σ} {c mdecl cdecl} : +Lemma closed_cstr_branch_context_gen {cf : checker_flags} {Σ} {wfΣ : wf Σ} {c mdecl cdecl} : closed_inductive_decl mdecl -> closed_constructor_body mdecl cdecl -> closedn_ctx (context_assumptions mdecl.(ind_params)) (cstr_branch_context c mdecl cdecl). diff --git a/pcuic/theories/Conversion/PCUICInstConv.v b/pcuic/theories/Conversion/PCUICInstConv.v index 7463430b0..4159f8bfc 100644 --- a/pcuic/theories/Conversion/PCUICInstConv.v +++ b/pcuic/theories/Conversion/PCUICInstConv.v @@ -3,7 +3,7 @@ From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICOnOne PCUICTactics PCUICAstUtils PCUICCases PCUICInduction PCUICLiftSubst PCUICUnivSubst - PCUICTyping PCUICReduction PCUICCumulativity + PCUICTyping PCUICReduction PCUICCumulativity PCUICEquality PCUICGlobalEnv PCUICClosed PCUICClosedConv PCUICClosedTyp PCUICEquality PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICSigmaCalculus PCUICRenameDef PCUICRenameConv PCUICWeakeningConv PCUICInstDef PCUICWeakeningTyp PCUICGuardCondition PCUICUnivSubstitutionConv PCUICOnFreeVars PCUICOnFreeVarsConv. @@ -21,7 +21,7 @@ Implicit Types cf : checker_flags. Open Scope sigma_scope. -Definition inst_constructor_body mdecl f c := +Definition inst_constructor_body mdecl f c := map_constructor_body #|mdecl.(ind_params)| #|mdecl.(ind_bodies)| (fun k => inst (up k f)) c. @@ -1249,7 +1249,7 @@ Proof. Qed. Lemma on_free_vars_up (P Q : nat -> bool) n s: - (forall i, Q i -> on_free_vars P (s i)) -> + (forall i, Q i -> on_free_vars P (s i)) -> forall i, shiftnP n Q i -> on_free_vars (shiftnP n P) (up n s i). @@ -1284,10 +1284,10 @@ Proof. Qed. -Lemma usubst_on_free_vars_shift Γ Δ σ u n : +Lemma usubst_on_free_vars_shift Γ Δ σ u n : closed_subst Γ σ Δ -> - is_closed_context Γ -> - on_free_vars (shiftnP n (shiftnP #|Γ| xpred0)) u -> + is_closed_context Γ -> + on_free_vars (shiftnP n (shiftnP #|Γ| xpred0)) u -> on_free_vars (shiftnP n (shiftnP #|Δ| xpred0)) u.[up n σ]. Proof. intros. @@ -1325,7 +1325,7 @@ Lemma usubst_ext {Δ σ σ' Γ} : σ =1 σ' -> usubst Γ σ' Δ. Proof using Type. - intros Hσ eq n decl hnth. + intros Hσ eq n decl hnth. specialize (Hσ n decl hnth) as hb. intros b hd. specialize (hb b hd). destruct hb as [[x' [decl' [eqn [hnth' hsome]]]]|h]. @@ -1340,7 +1340,7 @@ Lemma closed_subst_ext {Δ σ σ' Γ} : closed_subst Γ σ' Δ. intros [HΔ Hσ] eq. destruct Hσ as [closed_σ Hσ]. repeat split; eauto. - intros n decl hnth. rewrite <- (eq n). eapply closed_σ; eauto. - - eapply usubst_ext; eauto. + - eapply usubst_ext; eauto. Qed. Lemma well_subst_ext Σ Δ σ σ' Γ : @@ -1348,17 +1348,17 @@ Lemma well_subst_ext Σ Δ σ σ' Γ : σ =1 σ' -> Σ ;;; Δ ⊢ σ' : Γ. Proof using Type. - intros Hσ eq. destruct Hσ as [typed_σ Hσ]. split. + intros Hσ eq. destruct Hσ as [typed_σ Hσ]. split. - intros n decl hnth. rewrite -(eq n). - eapply meta_conv. 2:now rewrite -eq. eapply typed_σ; eauto. - - eapply usubst_ext; eauto. + eapply meta_conv. 2:now rewrite -eq. eapply typed_σ; eauto. + - eapply usubst_ext; eauto. Qed. Lemma usubst_Up {Γ Δ σ na A} : - usubst Γ σ Δ -> + usubst Γ σ Δ -> usubst (Γ ,, vass na A) (⇑ σ) (Δ ,, vass na A.[σ]). Proof. - intros h [|n] decl e. + intros h [|n] decl e. * simpl in *. inversion e. subst. clear e. simpl => //. * cbn -[rshiftk] in *. specialize (h _ _ e) as h1. @@ -1380,13 +1380,13 @@ Proof. Defined. Lemma closed_subst_Up {Γ Δ σ na A} : - closed_subst Γ σ Δ -> - is_open_term Δ A.[σ] -> + closed_subst Γ σ Δ -> + is_open_term Δ A.[σ] -> closed_subst (Γ ,, vass na A) (⇑ σ) (Δ ,, vass na A.[σ]). Proof using Type. - intros [HΔ h] HAσ; repeat split. + intros [HΔ h] HAσ; repeat split. - rewrite on_free_vars_ctx_snoc. solve_all. - - intros [|n] decl e. + - intros [|n] decl e. * now inversion e. * cbn -[rshiftk] in *. rewrite /subst_compose. @@ -1394,7 +1394,7 @@ Proof using Type. 2: now eapply h. now easy. - eapply usubst_Up; eauto; intuition. -Qed. +Qed. Lemma well_subst_Up {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ σ na A} : wf_local Σ (Δ ,, vass na A.[σ]) -> @@ -1415,7 +1415,7 @@ Proof using Type. sigma in X. eapply X. * eapply inst_ext. rewrite ren_lift_renaming. now sigma. - - eapply usubst_Up; eauto; intuition. + - eapply usubst_Up; eauto; intuition. Qed. @@ -1424,13 +1424,13 @@ Lemma usubst_Up' {Γ Δ σ na t A} : usubst Γ σ Δ -> usubst (Γ ,, vdef na t A) (⇑ σ) (Δ ,, vdef na t.[σ] A.[σ]). Proof using Type. - intros h [|n] decl e. - * simpl in *. inversion e. subst. clear e. simpl. + intros h [|n] decl e. + * simpl in *. inversion e. subst. clear e. simpl. intros b [= ->]. left. exists 0. eexists _; intuition eauto. simpl. sigma. reflexivity. * cbn -[rshiftk] in *. - specialize (h _ _ e) as h2. + specialize (h _ _ e) as h2. + intros b hb. specialize (h2 _ hb) as [[x' [decl' [hrel [hnth hdecl]]]]|]. ++ left. exists (S x'), decl'. @@ -1446,19 +1446,19 @@ Proof using Type. ++ right. unfold subst_compose at 1. rewrite e0. now rewrite inst_assoc. -Qed. +Qed. Lemma closed_subst_Up' {Γ Δ σ na t A} : closed_subst Γ σ Δ -> - is_open_term Δ A.[σ] -> - is_open_term Δ t.[σ] -> + is_open_term Δ A.[σ] -> + is_open_term Δ t.[σ] -> closed_subst (Γ ,, vdef na t A) (⇑ σ) (Δ ,, vdef na t.[σ] A.[σ]). Proof using Type. - intros [HΔ h] HAσ Htσ; repeat split. + intros [HΔ h] HAσ Htσ; repeat split. - rewrite on_free_vars_ctx_snoc; solve_all. - unfold is_open_decl, test_decl; solve_all. - - intros [|n] decl e. - * simpl in *. inversion e. subst. clear e. simpl. eauto. + unfold is_open_decl, test_decl; solve_all. + - intros [|n] decl e. + * simpl in *. inversion e. subst. clear e. simpl. eauto. * cbn -[rshiftk] in *. rewrite /subst_compose. eapply on_free_vars_inst. @@ -1482,7 +1482,7 @@ Proof using Type. + rewrite lift0_inst /=. now autorewrite with sigma. * cbn -[rshiftk] in *. - specialize (h.1 _ _ e). + specialize (h.1 _ _ e). sigma. sigma in h. intro. eapply meta_conv. + epose proof (weakening_rename_typing (Γ' := []) (Γ'' := [_]) wf X). @@ -1490,7 +1490,7 @@ Proof using Type. sigma in X0. eapply X0. + eapply inst_ext. rewrite ren_lift_renaming. now sigma. - - eapply usubst_Up'; eauto; intuition. + - eapply usubst_Up'; eauto; intuition. Qed. @@ -1503,18 +1503,18 @@ Proof. induction Δ' as [|[na [b|] ty] Δ']. - eapply usubst_ext; eauto. now rewrite Upn_0. - - rewrite inst_context_snoc. - eapply usubst_ext. + - rewrite inst_context_snoc. + eapply usubst_ext. 2:now rewrite Upn_S. simpl. apply usubst_Up'. intuition. - rewrite inst_context_snoc. eapply usubst_ext. 2:now rewrite Upn_S. simpl. apply usubst_Up. intuition. -Defined. +Defined. Lemma closed_subst_app {Γ Δ σ Δ'} : closed_subst Γ σ Δ -> - on_free_vars_ctx (shiftnP #|Δ| xpred0) (inst_context σ Δ') -> + on_free_vars_ctx (shiftnP #|Δ| xpred0) (inst_context σ Δ') -> closed_subst (Γ ,,, Δ') (⇑^#|Δ'| σ) (Δ ,,, inst_context σ Δ'). Proof. intros hs hΔ'. @@ -1522,27 +1522,27 @@ Proof. - eapply closed_subst_ext; eauto. now rewrite Upn_0. - rewrite inst_context_snoc. rewrite inst_context_snoc in hΔ'. - rewrite on_free_vars_ctx_snoc in hΔ'. toProp hΔ'. - eapply closed_subst_ext. + rewrite on_free_vars_ctx_snoc in hΔ'. toProp hΔ'. + eapply closed_subst_ext. 2:now rewrite Upn_S. simpl. apply closed_subst_Up'. + intuition. + solve_all. unfold on_free_vars_decl, test_decl in H0. toProp H0. - cbn in H0. rewrite shiftnP_add in H0. rewrite <- app_length in H0. - destruct H0; tea. + cbn in H0. rewrite shiftnP_add in H0. rewrite <- app_length in H0. + destruct H0; tea. + solve_all. unfold on_free_vars_decl, test_decl in H0. toProp H0. - cbn in H0. rewrite shiftnP_add in H0. rewrite <- app_length in H0. - destruct H0; tea. + cbn in H0. rewrite shiftnP_add in H0. rewrite <- app_length in H0. + destruct H0; tea. - rewrite inst_context_snoc. rewrite inst_context_snoc in hΔ'. - rewrite on_free_vars_ctx_snoc in hΔ'. toProp hΔ'. + rewrite on_free_vars_ctx_snoc in hΔ'. toProp hΔ'. eapply closed_subst_ext. 2:now rewrite Upn_S. simpl. apply closed_subst_Up. + intuition. + solve_all. unfold on_free_vars_decl, test_decl in H0. toProp H0. - cbn in H0. rewrite shiftnP_add in H0. rewrite <- app_length in H0. - destruct H0; tea. -Defined. + cbn in H0. rewrite shiftnP_add in H0. rewrite <- app_length in H0. + destruct H0; tea. +Defined. Lemma well_subst_app {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ σ Δ'} : wf_local Σ (Δ ,,, inst_context σ Δ') -> @@ -1582,7 +1582,7 @@ Qed. Lemma closed_subst_app_up {Γ Δ σ Δ'} : closed_subst Γ σ Δ -> - on_free_vars_ctx (shiftnP #|Δ| xpred0) (inst_context σ Δ') -> + on_free_vars_ctx (shiftnP #|Δ| xpred0) (inst_context σ Δ') -> closed_subst (Γ ,,, Δ') (up #|Δ'| σ) (Δ ,,, inst_context σ Δ'). Proof using Type. intros hs hΔ'. @@ -1638,7 +1638,7 @@ Qed. Lemma closed_subst_up_vass {Γ Δ σ na A} : closed_subst Γ σ Δ -> - is_open_term Δ A.[σ] -> + is_open_term Δ A.[σ] -> closed_subst (Γ ,, vass na A) (up 1 σ) (Δ ,, vass na A.[σ]). Proof using Type. intros H HA. @@ -1656,8 +1656,8 @@ Qed. Lemma closed_subst_up_vdef {Γ Δ σ na t A} : closed_subst Γ σ Δ -> - is_open_term Δ A.[σ] -> - is_open_term Δ t.[σ] -> + is_open_term Δ A.[σ] -> + is_open_term Δ t.[σ] -> closed_subst (Γ ,, vdef na t A) (up 1 σ) (Δ ,, vdef na t.[σ] A.[σ]). Proof using Type. intros H Ha Ht. @@ -1665,10 +1665,10 @@ Proof using Type. now rewrite up_Upn; sigma. Qed. -Lemma inst_is_open_term Γ Δ σ u : - closed_subst Γ σ Δ -> - is_closed_context Γ -> - is_open_term Γ u -> +Lemma inst_is_open_term Γ Δ σ u : + closed_subst Γ σ Δ -> + is_closed_context Γ -> + is_open_term Γ u -> is_open_term Δ u.[σ]. Proof using Type. intros H ? ?. @@ -1679,15 +1679,15 @@ Proof using Type. now eapply H. Qed. -Lemma on_free_vars_ctx_inst_case_context_nil - (P : nat -> bool) - (pars : list term) (puinst : Instance.t) +Lemma on_free_vars_ctx_inst_case_context_nil + (P : nat -> bool) + (pars : list term) (puinst : Instance.t) (pctx : list context_decl) : forallb (on_free_vars P) pars -> on_free_vars_ctx (closedP #|pars| xpredT) pctx -> on_free_vars_ctx P (inst_case_context pars puinst pctx). Proof. - intros. + intros. assert (on_free_vars_ctx P ([] ,,, inst_case_context pars puinst pctx)). { apply on_free_vars_ctx_inst_case_context. - cbn. rewrite shiftnP0; eauto. @@ -1695,11 +1695,11 @@ Proof. - eauto. } rewrite on_free_vars_ctx_app in H1. solve_all. cbn in *. rewrite shiftnP0 in H2. tea. -Defined. +Defined. Lemma red1_inst {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ u v σ} : usubst Γ σ Δ -> - is_open_term Γ u -> + is_open_term Γ u -> red1 Σ Γ u v -> red Σ Δ u.[σ] v.[σ]. Proof. @@ -1714,7 +1714,7 @@ Proof. - rewrite subst10_inst. sigma. do 2 constructor. - rewrite subst10_inst. sigma. do 2 constructor. - destruct (nth_error Γ i) eqn:hnth; noconf H. - red in hσ. specialize hσ with (1 := hnth) as IH. + red in hσ. specialize hσ with (1 := hnth) as IH. specialize IH with (1:=H) as [[x' [decl' [hi [hnth' eqbod]]]]|eqr]. * rewrite /= hi. sigma. destruct (decl_body decl') eqn:hdecl => //. noconf eqbod. @@ -1753,14 +1753,14 @@ Proof. do 2 econstructor. rewrite nth_error_map. rewrite H. reflexivity. - simpl. eapply red_abs; eauto. - simpl; eapply red_abs; eauto. - eapply IHh; tea. + eapply IHh; tea. + eapply usubst_up_vass; eauto. + rewrite shiftnP_add in b. change 1 with #|[vass na N]| in b. rewrite <- app_length in b. apply b. - simpl; eapply red_letin; eauto. - simpl; eapply red_letin; eauto. - simpl; pcuicfo. eapply red_letin; eauto. eapply IHh; tea; try eapply usubst_up_vdef; try eapply inst_is_open_term; eauto. - + rewrite shiftnP_add in p1. tea. + + rewrite shiftnP_add in p1. tea. - simpl. rewrite inst_predicate_set_pparams. eapply red_case_pars. simpl. eapply All2_map. @@ -1773,9 +1773,9 @@ Proof. + rewrite /PCUICCases.inst_case_predicate_context. rewrite /= -inst_inst_case_context_wf //. { now rewrite test_context_k_closed_on_free_vars_ctx. } - relativize #|pcontext p|; [eapply usubst_app_up|now len]; eauto. + relativize #|pcontext p|; [eapply usubst_app_up|now len]; eauto. + rewrite shiftnP_add in p1. rewrite <- inst_case_predicate_context_length in p1. - rewrite <- app_length in p1. tea. + rewrite <- app_length in p1. tea. - simpl. eapply red_case_c; eauto. - simpl. eapply red_case_brs; eauto. red. @@ -1790,16 +1790,16 @@ Proof. rewrite -inst_inst_case_context_wf //; simpl. relativize #|bcontext x|; [eapply usubst_app_up|now len]; eauto. + rewrite shiftnP_add in clb. erewrite <- inst_case_branch_context_length in clb. - rewrite <- app_length in clb. tea. + rewrite <- app_length in clb. tea. * intros x. unfold on_Trel; split; auto. - simpl. now eapply red_proj_c. - simpl. now eapply red_app. - simpl. now eapply red_app_r. - simpl. now eapply red_prod. - simpl. eapply red_prod_r, IHh; tea. - * eapply usubst_up_vass; eauto. - * rewrite shiftnP_add in b. change 1 with #|[vass na M1]| in b. - rewrite <- app_length in b. tea. + * eapply usubst_up_vass; eauto. + * rewrite shiftnP_add in b. change 1 with #|[vass na M1]| in b. + rewrite <- app_length in b. tea. - simpl. cbn in Hu. solve_all. eapply OnOne2_All_mix_left in X; tea. eapply red_evar. @@ -1823,7 +1823,7 @@ Proof. * eapply usubst_ext. + rewrite inst_fix_context_up. eapply usubst_app_up; eauto. + now len. - * rewrite shiftnP_add in onb. rewrite <- fix_context_length in onb. rewrite <- app_length in onb. tea. + * rewrite shiftnP_add in onb. rewrite <- fix_context_length in onb. rewrite <- app_length in onb. tea. - simpl. cbn in Hu; solve_all. eapply OnOne2_All_mix_left in X; tea. eapply red_cofix_one_ty. rewrite (OnOne2_length X). @@ -1900,11 +1900,11 @@ Proof using Type. - eapply red_conv_conv. + eapply red1_inst; tea. + apply IHh; tea. - eapply red1_on_free_vars; tea. + eapply red1_on_free_vars; tea. - eapply red_conv_conv_inv. + eapply red1_inst; tea. + eapply IHh; eauto. - eapply red1_on_free_vars; tea. + eapply red1_on_free_vars; tea. Qed. Lemma inst_cumul {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ σ A B} : diff --git a/pcuic/theories/Conversion/PCUICNamelessConv.v b/pcuic/theories/Conversion/PCUICNamelessConv.v index dfe0c1648..b7658f5b6 100644 --- a/pcuic/theories/Conversion/PCUICNamelessConv.v +++ b/pcuic/theories/Conversion/PCUICNamelessConv.v @@ -12,8 +12,8 @@ Implicit Types cf : checker_flags. (** Conversion does not rely on name annotations of binders. - We prove this by constructing a type-preserving translation to - terms where all binders are anonymous. An alternative would be to + We prove this by constructing a type-preserving translation to + terms where all binders are anonymous. An alternative would be to be parametrically polymorphic everywhere on the binder name type. This would allow to add implicit information too. *) @@ -113,7 +113,7 @@ Proof. eapply eq_univ_make. assumption. - f_equal ; try solve [ ih ]. * destruct e as [eqpar [eqinst [eqctx eqret]]]. - destruct X as [? [? ?]]. + destruct X as [? [? ?]]. destruct p, p'; simpl in *. f_equal. + apply All2_eq; solve_all. + red in eqinst. @@ -304,7 +304,7 @@ Lemma eq_context_nl_IH Σ Re ctx ctx' : (map (map_decl_anon nl) ctx'). Proof. intros aux H. - induction H; simpl; constructor; simpl; destruct p; simpl; + induction H; simpl; constructor; simpl; destruct p; simpl; intuition (constructor; auto); subst; reflexivity. Defined. @@ -357,7 +357,7 @@ Lemma eq_context_nl Σ Re Rle ctx ctx' : (nlctx ctx) (nlctx ctx'). Proof. intros H. - induction H; constructor; simpl; destruct p; intuition + induction H; constructor; simpl; destruct p; intuition (constructor; auto using nl_eq_term_upto_univ). Qed. @@ -409,7 +409,7 @@ Local Ltac ih3 := (*Lemma eq_context_nl_inv_IH Σ Re ctx ctx' : onctx (fun u : term => - forall (Rle : Universe.t -> Universe.t -> Prop) + forall (Rle : Universe.t -> Universe.t -> Prop) (napp : nat) (v : term), eq_term_upto_univ_napp Σ Re Rle napp (nl u) (nl v) -> eq_term_upto_univ_napp Σ Re Rle napp u v) ctx -> @@ -417,10 +417,10 @@ Local Ltac ih3 := eq_context_gen eq eq ctx ctx'. Proof. intros Hctx. unfold ondecl in *. - induction ctx as [|[na [b|] ty] Γ] in ctx', Hctx |- *; + induction ctx as [|[na [b|] ty] Γ] in ctx', Hctx |- *; destruct ctx' as [|[na' [b'|] ty'] Δ]; simpl; intros H; depelim H; constructor; simpl in *; depelim Hctx; intuition eauto. - * depelim c; constructor; auto. + * depelim c; constructor; auto. + cbn in *. * depelim c. * depelim c. @@ -475,7 +475,7 @@ Proof. destruct n; reflexivity. Qed. Hint Resolve binder_anonymize : core. #[global] Hint Constructors compare_decls : core. Local Hint Unfold map_decl_anon : core. -(* +(* Lemma eq_term_upto_univ_tm_nl : forall Σ Re Rle napp u, Reflexive Re -> @@ -497,7 +497,7 @@ Proof. + reflexivity. + clear -a0 hRe hRle. induction a0. { constructor; auto. } - destruct x as [na [b|] ty]; simpl; constructor; auto; + destruct x as [na [b|] ty]; simpl; constructor; auto; destruct p; simpl in *; intuition (simpl; auto); constructor; auto. * induction l. @@ -507,7 +507,7 @@ Proof. ++ simpl. clear -hRe hRle a0. induction a0; [constructor; auto|]. - destruct x as [na [b|] ty]; simpl; constructor; auto; + destruct x as [na [b|] ty]; simpl; constructor; auto; destruct p; simpl in *; intuition auto; constructor; auto. ++ auto. ++ eapply IHl. assumption. @@ -629,7 +629,7 @@ Qed. Lemma global_ext_constraints_nlg : forall Σ, global_ext_constraints (nlg Σ) = global_ext_constraints Σ. -Proof. +Proof. intros [[univs g] ?]. reflexivity. Qed. @@ -786,7 +786,7 @@ Lemma nl_eq_decl {cf:checker_flags} : compare_decl le Σ φ d d' -> compare_decl le (nl_global_env Σ) φ (map_decl nl d) (map_decl nl d'). Proof. - intros le Σ φ d d' []; constructor; destruct le; + intros le Σ φ d d' []; constructor; destruct le; intuition auto using nl_eq_term, nl_leq_term. Qed. @@ -822,11 +822,11 @@ Proof. apply IHt1. Qed. -Lemma nl_pred_set_preturn p pret : nl_predicate nl (set_preturn p pret) = +Lemma nl_pred_set_preturn p pret : nl_predicate nl (set_preturn p pret) = set_preturn (nl_predicate nl p) (nl pret). Proof. reflexivity. Qed. -Lemma nl_pred_set_pparams p pret : nl_predicate nl (set_pparams p pret) = +Lemma nl_pred_set_pparams p pret : nl_predicate nl (set_pparams p pret) = set_pparams (nl_predicate nl p) (map nl pret). Proof. reflexivity. Qed. @@ -911,7 +911,7 @@ Proof. - simpl. f_equal; auto. rewrite /subst_decl /map_decl /= /map_decl_anon /=; repeat f_equal. * now rewrite nl_subst; len. - * now rewrite nl_subst; len. + * now rewrite nl_subst; len. - simpl. f_equal; [|apply ih]. rewrite /subst_decl /map_decl /= /map_decl_anon /=; repeat f_equal. now rewrite nl_subst; len. @@ -929,7 +929,7 @@ Proof. - simpl. f_equal; auto. rewrite /lift_decl /map_decl /= /map_decl_anon /=; repeat f_equal. * now rewrite nl_lift; len. - * now rewrite nl_lift; len. + * now rewrite nl_lift; len. - simpl. f_equal; [|apply ih]. rewrite /subst_decl /map_decl /= /map_decl_anon /=; repeat f_equal. now rewrite nl_lift; len. @@ -957,16 +957,16 @@ Qed. #[global] Hint Rewrite nl_context_assumptions : len. -Lemma nl_expand_lets_k Γ k t : - nl (expand_lets_k Γ k t) = +Lemma nl_expand_lets_k Γ k t : + nl (expand_lets_k Γ k t) = expand_lets_k (nlctx Γ) k (nl t). Proof. rewrite /expand_lets_k. now rewrite nl_subst nl_extended_subst nl_lift; len; autorewrite with len. Qed. -Lemma nl_expand_lets Γ t : - nl (expand_lets Γ t) = +Lemma nl_expand_lets Γ t : + nl (expand_lets Γ t) = expand_lets (nlctx Γ) (nl t). Proof. now rewrite /expand_lets nl_expand_lets_k. @@ -981,13 +981,13 @@ Proof. all: now rewrite nl_subst_instance. Qed. -Lemma map_anon_fold_context_k g g' ctx : +Lemma map_anon_fold_context_k g g' ctx : (forall i, nl ∘ g i =1 g' i ∘ nl) -> - map (map_decl_anon nl) (fold_context_k g ctx) = + map (map_decl_anon nl) (fold_context_k g ctx) = fold_context_k g' (map (map_decl_anon nl) ctx). Proof. intros hg. - rewrite !fold_context_k_alt map_mapi mapi_map. + rewrite !fold_context_k_alt map_mapi mapi_map. apply mapi_ext => i d. rewrite /map_decl /map_decl_anon. len. f_equal. @@ -997,16 +997,16 @@ Proof. Qed. Lemma nl_subst_context s k ctx : - nlctx (subst_context s k ctx) = + nlctx (subst_context s k ctx) = subst_context (map nl s) k (nlctx ctx). Proof. rewrite /nlctx /subst_context. - apply map_anon_fold_context_k. + apply map_anon_fold_context_k. intros i x. now rewrite nl_subst. Qed. Lemma nl_subst_telescope s k ctx : - nlctx (subst_telescope s k ctx) = + nlctx (subst_telescope s k ctx) = subst_telescope (map nl s) k (nlctx ctx). Proof. rewrite /nlctx /subst_telescope. @@ -1016,16 +1016,16 @@ Proof. Qed. Lemma nl_lift_context n k ctx : - nlctx (lift_context n k ctx) = + nlctx (lift_context n k ctx) = lift_context n k (nlctx ctx). Proof. rewrite /nlctx /subst_context. - apply map_anon_fold_context_k. + apply map_anon_fold_context_k. intros i x. now rewrite nl_lift. Qed. -Lemma nl_expand_lets_ctx Γ Δ : - nlctx (expand_lets_ctx Γ Δ) = +Lemma nl_expand_lets_ctx Γ Δ : + nlctx (expand_lets_ctx Γ Δ) = expand_lets_ctx (nlctx Γ) (nlctx Δ). Proof. rewrite /expand_lets_ctx /expand_lets_k_ctx. @@ -1041,14 +1041,14 @@ Proof. Qed. -Lemma map_map2 {A B C D} (f : A -> B) (g : C -> D -> A) l l' : +Lemma map_map2 {A B C D} (f : A -> B) (g : C -> D -> A) l l' : map f (map2 g l l') = map2 (fun x y => f (g x y)) l l'. Proof. induction l in l' |- *; destruct l'; simpl; auto. f_equal. apply IHl. Qed. -Lemma map2_map {A A' B B' C} (f : A -> B) (f' : A' -> B') (g : B -> B' -> C) l l' : +Lemma map2_map {A A' B B' C} (f : A -> B) (f' : A' -> B') (g : B -> B' -> C) l l' : map2 g (map f l) (map f' l') = map2 (fun x y => g (f x) (f' y)) l l'. Proof. induction l in l' |- *; destruct l'; simpl; auto. f_equal. @@ -1067,7 +1067,7 @@ Proof. Qed. Lemma map2_ext {A B C} (f g : A -> B -> C) (l : list A) (l' : list B) : - (forall x y, f x y = g x y) -> + (forall x y, f x y = g x y) -> map2 f l l' = map2 g l l'. Proof. intros H. @@ -1092,7 +1092,7 @@ Proof. *) -Lemma nlctx_smash_context Γ Δ : +Lemma nlctx_smash_context Γ Δ : nlctx (smash_context Γ Δ) = smash_context (nlctx Γ) (nlctx Δ). Proof. induction Δ as [|[na [b|] ty] Δ] in Γ |- *; simpl; auto. @@ -1102,7 +1102,7 @@ Qed. Lemma nl_case_predicate_context ind mdecl idecl p : nlctx (case_predicate_context ind mdecl idecl p) = - case_predicate_context ind (nl_mutual_inductive_body mdecl) (nl_one_inductive_body idecl) + case_predicate_context ind (nl_mutual_inductive_body mdecl) (nl_one_inductive_body idecl) (nl_predicate nl p). Proof. unfold case_predicate_context, case_predicate_context_gen. @@ -1139,21 +1139,21 @@ Qed. Lemma nl_case_branch_context ind mdecl p br cdecl : nlctx (case_branch_context ind mdecl p br cdecl) = case_branch_context ind (nl_mutual_inductive_body mdecl) - (nl_predicate nl p) (map anonymize br) + (nl_predicate nl p) (map anonymize br) (nl_constructor_body cdecl). Proof. unfold case_branch_context, case_branch_context_gen. simpl. - rewrite /pre_case_branch_context_gen. + rewrite /pre_case_branch_context_gen. rewrite /nlctx -nl_cstr_branch_context -nl_inst_case_context. cbn. now rewrite map_map2 map2_map. Qed. -Lemma nl_case_branch_type ci mdecl idecl p br i cdecl : +Lemma nl_case_branch_type ci mdecl idecl p br i cdecl : let ptm := it_mkLambda_or_LetIn (case_predicate_context ci mdecl idecl p) (preturn p) in case_branch_type ci (nl_mutual_inductive_body mdecl) - (nl_one_inductive_body idecl) (nl_predicate nl p) + (nl_one_inductive_body idecl) (nl_predicate nl p) (nl_branch nl br) - (nl ptm) i (nl_constructor_body cdecl) = + (nl ptm) i (nl_constructor_body cdecl) = map_pair nlctx nl (case_branch_type ci mdecl idecl p br ptm i cdecl). Proof. intros ptm. @@ -1173,18 +1173,18 @@ Proof. now rewrite nl_to_extended_list. Qed. -Lemma nl_forget_types ctx : - forget_types (map (map_decl_anon nl) ctx) = +Lemma nl_forget_types ctx : + forget_types (map (map_decl_anon nl) ctx) = map anonymize (forget_types ctx). Proof. now rewrite /forget_types !map_map_compose. Qed. -Lemma nl_wf_predicate mdecl idecl p : +Lemma nl_wf_predicate mdecl idecl p : wf_predicate mdecl idecl p -> wf_predicate (nl_mutual_inductive_body mdecl) (nl_one_inductive_body idecl) (nl_predicate nl p). Proof. - intros []; split. + intros []; split. { len => //. } depelim H0. simpl. rewrite nl_forget_types H2 /=. constructor; auto. @@ -1193,7 +1193,7 @@ Qed. Lemma nl_wf_branch cdecl br : wf_branch cdecl br -> - wf_branch (nl_constructor_body cdecl) (nl_branch nl br). + wf_branch (nl_constructor_body cdecl) (nl_branch nl br). Proof. unfold wf_branch, wf_branch_gen. simpl. @@ -1203,7 +1203,7 @@ Qed. Lemma nl_wf_branches idecl brs : wf_branches idecl brs -> - wf_branches (nl_one_inductive_body idecl) (map (nl_branch nl) brs). + wf_branches (nl_one_inductive_body idecl) (map (nl_branch nl) brs). Proof. unfold wf_branches, wf_branches_gen. simpl. intros H; apply Forall2_map. @@ -1215,7 +1215,7 @@ Lemma closed_ctx_IH : forall (l : list context_decl) (n : nat), onctx_k (fun (k : nat) (t : term) => closedn k (nl t)) n l -> closedn_ctx n (map (map_decl_anon nl) l). -Proof. +Proof. unfold onctx_k. intros l n. solve_all. induction l; simpl; auto. len. @@ -1430,7 +1430,7 @@ Lemma nl_cumul_ctx {cf} {Σ Γ Δ} : cumul_context cumulAlgo_gen (nlg Σ) (nlctx Γ) (nlctx Δ). Proof. intros. - induction X; simpl; constructor; eauto; simpl; now + induction X; simpl; constructor; eauto; simpl; now (eapply nl_conv_decls in p || eapply nl_cumul_decls in p). Qed. #[global] Hint Resolve nl_cumul_ctx : nl. @@ -1449,7 +1449,7 @@ Proof. Qed. -Lemma All2i_map {A B C D} (f : A -> B) (g : C -> D) P n l l' : +Lemma All2i_map {A B C D} (f : A -> B) (g : C -> D) P n l l' : All2i (fun i x y => P i (f x) (g y)) n l l' <~> All2i P n (map f l) (map g l'). Proof. @@ -1529,7 +1529,7 @@ Proof. destruct p, x; unfold map_def_anon; simpl in *. rewrite anonymize_two; congruence. - f_equal. induction X; cbnr. f_equal; tas. - destruct p, x; unfold map_def_anon; simpl in *. + destruct p, x; unfold map_def_anon; simpl in *. rewrite anonymize_two; congruence. Qed. diff --git a/pcuic/theories/Conversion/PCUICOnFreeVarsConv.v b/pcuic/theories/Conversion/PCUICOnFreeVarsConv.v index b7704aca8..e7bdd009a 100644 --- a/pcuic/theories/Conversion/PCUICOnFreeVarsConv.v +++ b/pcuic/theories/Conversion/PCUICOnFreeVarsConv.v @@ -1,8 +1,8 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import Morphisms. +From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction - PCUICLiftSubst PCUICUnivSubst PCUICSigmaCalculus PCUICClosed + PCUICLiftSubst PCUICUnivSubst PCUICSigmaCalculus PCUICClosed PCUICOnFreeVars PCUICTyping PCUICReduction PCUICGlobalEnv PCUICWeakeningEnvConv PCUICClosedConv PCUICWeakeningEnvTyp PCUICInstDef PCUICRenameDef PCUICRenameConv. @@ -54,7 +54,7 @@ Proof. Qed. Lemma shiftn_ext_cond (P : nat -> bool) f f' n : - (forall i, P i -> f i = f' i) -> + (forall i, P i -> f i = f' i) -> forall k, shiftnP n P k -> shiftn n f k = shiftn n f' k. @@ -65,9 +65,9 @@ Proof. now f_equal. Qed. -Lemma rename_ext_cond (P : nat -> bool) f f' t : +Lemma rename_ext_cond (P : nat -> bool) f f' t : ( forall i, P i -> f i = f' i ) -> - on_free_vars P t -> + on_free_vars P t -> rename f t = rename f' t. Proof. intros H Ht. @@ -100,38 +100,38 @@ Proof. Qed. -Lemma urename_on_free_vars_shift P Γ Δ f u (Ξ: context) : +Lemma urename_on_free_vars_shift P Γ Δ f u (Ξ: context) : let sP := shiftnP #|Γ| P in - urenaming sP Δ Γ f -> - is_closed_context Γ -> - is_closed_context Δ -> - on_free_vars (shiftnP #|Ξ| (shiftnP #|Γ| xpred0)) u -> - on_free_vars (shiftnP #|Ξ| (shiftnP #|Δ| xpred0)) + urenaming sP Δ Γ f -> + is_closed_context Γ -> + is_closed_context Δ -> + on_free_vars (shiftnP #|Ξ| (shiftnP #|Γ| xpred0)) u -> + on_free_vars (shiftnP #|Ξ| (shiftnP #|Δ| xpred0)) (rename (shiftn #|Ξ| f) u). Proof. intros sP hf HΓ HΔ Hu. rewrite on_free_vars_rename. eapply on_free_vars_impl. 2: tea. clear Hu. intros n Hn. - apply urenaming_context with (Ξ:=Ξ) in hf. - unfold urenaming in hf. + apply urenaming_context with (Ξ:=Ξ) in hf. + unfold urenaming in hf. specialize (hf n). destruct (nth_error (Γ,,, Ξ) n) eqn : Hnth. - - specialize (hf c); cbn in hf. forward hf. + - specialize (hf c); cbn in hf. forward hf. * unfold shiftnP in Hn. unfold sP , shiftnP. toProp. toProp Hn. destruct Hn. + intuition. - + right. toProp. toProp H. destruct H; intuition. + + right. toProp. toProp H. destruct H; intuition. * destruct (hf eq_refl) as [decl' [Hfn _]]. - clear hf Hn. unfold sP , shiftnP. rewrite orb_false_r. - assert (shiftn #|Ξ| f n < #|Δ,,, rename_context f Ξ|). + clear hf Hn. unfold sP , shiftnP. rewrite orb_false_r. + assert (shiftn #|Ξ| f n < #|Δ,,, rename_context f Ξ|). { eapply nth_error_Some'. exists decl'. eauto. } rewrite app_context_length in H. rewrite rename_context_length in H. toProp. clear -H. - repeat rewrite PeanoNat.Nat.ltb_lt. lia. + repeat rewrite PeanoNat.Nat.ltb_lt. lia. - rewrite nth_error_None in Hnth. rewrite app_context_length in Hnth. unfold shiftnP in *. toProp Hn. toProp. unfold shiftn. clear -Hn Hnth. destruct Hn. * toProp H. intuition. - * toProp H. destruct H; [toProp H |]; intuition. -Defined. + * toProp H. destruct H; [toProp H |]; intuition. +Defined. Lemma urename_is_open_term P Γ Δ f u : let sP := shiftnP #|Γ| P in urenaming sP Δ Γ f -> is_closed_context Γ -> is_closed_context Δ -> is_open_term Γ u -> is_open_term Δ (rename f u). @@ -141,13 +141,13 @@ Proof. rewrite <- (shiftnP0 (shiftnP #|Δ| xpred0)). rewrite <- (shiftn0 f). eapply urename_on_free_vars_shift with (Ξ:=[]); eauto. - rewrite shiftnP0; eauto. -Defined. + rewrite shiftnP0; eauto. +Defined. -Lemma on_free_vars_ctx_inst_case_context +Lemma on_free_vars_ctx_inst_case_context P (Γ : list context_decl) (pars : list term) (puinst : Instance.t) (pctx : list context_decl) : forallb (on_free_vars (shiftnP #|Γ| P)) pars -> @@ -162,55 +162,55 @@ Qed. Lemma rename_context_on_free_vars f n l : -on_free_vars_ctx (closedP n xpredT) l -> +on_free_vars_ctx (closedP n xpredT) l -> rename_context (shiftn n f) l = l. Proof. - intro Hclosed. - unfold on_free_vars_ctx in Hclosed. - unfold rename_context, fold_context_k. + intro Hclosed. + unfold on_free_vars_ctx in Hclosed. + unfold rename_context, fold_context_k. induction l; eauto. cbn in *. rewrite alli_app in Hclosed. toProp Hclosed. - destruct Hclosed as [H Hclosed]. + destruct Hclosed as [H Hclosed]. rewrite mapi_rec_app. rewrite List.distr_rev. rewrite IHl; eauto. cbn in *. f_equal. toProp Hclosed. destruct Hclosed as [Hclosed _]. destruct a; unfold map_decl; cbn. - unfold on_free_vars_decl in Hclosed. + unfold on_free_vars_decl in Hclosed. unfold test_decl in Hclosed. toProp Hclosed. cbn in Hclosed. destruct Hclosed as [Hbody Htype]. f_equal. - - destruct decl_body; eauto; cbn in *. + - destruct decl_body; eauto; cbn in *. f_equal. rewrite closedP_shiftnP in Hbody. rewrite shiftnP_add in Hbody. rewrite shiftn_add. apply rename_on_free_vars; eauto. - rewrite closedP_shiftnP in Htype. rewrite shiftnP_add in Htype. rewrite shiftn_add. apply rename_on_free_vars; eauto. -Defined. +Defined. -Lemma inst_case_predicate_context_rename f p : +Lemma inst_case_predicate_context_rename f p : on_free_vars_ctx (closedP #|pparams p| xpredT) (pcontext p) -> inst_case_predicate_context (rename_predicate f p) = rename_context f (inst_case_predicate_context p). -Proof. +Proof. intro Hclosed. unfold inst_case_predicate_context. unfold pparams at 1. cbn. - replace (pcontext p) with + replace (pcontext p) with (rename_context (shiftn #|(pparams p)| f) (pcontext p)) at 1. - rewrite <- rename_inst_case_context. reflexivity. - apply rename_context_on_free_vars; eauto. -Defined. +Defined. Lemma inst_case_branch_context_rename f p x : -on_free_vars_ctx (closedP #|pparams p| xpredT) (bcontext x) -> -inst_case_branch_context (rename_predicate f p) +on_free_vars_ctx (closedP #|pparams p| xpredT) (bcontext x) -> +inst_case_branch_context (rename_predicate f p) (rename_branch f x) = rename_context f (inst_case_branch_context p x). Proof. - intro Hclosed. unfold inst_case_branch_context. cbn. - replace (bcontext x) with + intro Hclosed. unfold inst_case_branch_context. cbn. + replace (bcontext x) with (rename_context (shiftn #|(pparams p)| f) (bcontext x)) at 1. - rewrite <- rename_inst_case_context. reflexivity. - apply rename_context_on_free_vars; eauto. -Defined. +Defined. diff --git a/pcuic/theories/Conversion/PCUICRenameConv.v b/pcuic/theories/Conversion/PCUICRenameConv.v index 46956f7ec..c9d238c34 100644 --- a/pcuic/theories/Conversion/PCUICRenameConv.v +++ b/pcuic/theories/Conversion/PCUICRenameConv.v @@ -58,7 +58,7 @@ Proof. Qed. Lemma decompose_app_rec_rename r t l : - forall hd args, + forall hd args, decompose_app_rec t l = (hd, args) -> decompose_app_rec (rename r t) (map (rename r) l) = (rename r hd, map (rename r) args). Proof. @@ -544,7 +544,7 @@ Definition rename_constructor_body mdecl f c := map_constructor_body #|mdecl.(ind_params)| #|mdecl.(ind_bodies)| (fun k => rename (shiftn k f)) c. -(* TODO move *) +(* TODO move *) Lemma map2_set_binder_name_fold bctx f Γ : #|bctx| = #|Γ| -> map2 set_binder_name bctx (fold_context_k f Γ) = diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index 0445e23c3..c43c6f96f 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -102,7 +102,7 @@ Lemma subst_instance_level_val' u l v Proof. now apply subst_instance_level_val. Qed. - + Lemma subst_instance_univ0_val' u exprs v : val v (subst_instance_univ0 u exprs) = val (subst_instance_valuation u v) exprs. @@ -262,7 +262,7 @@ Proof. subst val1. apply map_spec in ine'' as [e0 [ine0 eq]]. specialize (He e0). subst e''. - etransitivity. + etransitivity. - eassumption. - eapply H. eapply map_spec. @@ -332,7 +332,7 @@ Lemma subst_instance_two_instance u1 u2 (u : Instance.t) : subst_instance u1 (subst_instance u2 u) = subst_instance (subst_instance u1 u2) u. Proof. - rewrite /subst_instance /= /subst_instance_instance. + rewrite /subst_instance /= /subst_instance_instance. rewrite map_map. apply map_ext, subst_instance_level_two. Qed. @@ -436,7 +436,7 @@ Lemma is_prop_subst_instance_univ u l : Universe.is_prop (subst_instance_univ u l) = Universe.is_prop l. Proof. destruct l; cbnr. -Qed. +Qed. Lemma is_sprop_subst_instance_univ u l : Universe.is_sprop (subst_instance_univ u l) = Universe.is_sprop l. @@ -475,7 +475,7 @@ Proof. Qed. Lemma consistent_instance_declared {cf: checker_flags} lvs φ uctx u : - consistent_instance lvs φ uctx u -> + consistent_instance lvs φ uctx u -> forallb (fun l => LS.mem l lvs) u. Proof. unfold consistent_instance. destruct uctx as [|ctx]. @@ -545,13 +545,13 @@ Qed. Definition wf_ext_wk {cf : checker_flags} (Σ : global_env_ext) := wf Σ.1 × on_udecl_prop Σ.1 Σ.2. - + Lemma wf_ext_wk_wf {cf:checker_flags} Σ : wf_ext_wk Σ -> wf Σ. Proof. intro H; apply H. Qed. #[global] Hint Resolve wf_ext_wk_wf : core. - + Lemma not_var_global_ext_levels {cf : checker_flags} Σ (hΣ : wf_ext_wk (Σ, Monomorphic_ctx)) : LS.For_all (negb ∘ Level.is_var) (global_ext_levels (Σ, Monomorphic_ctx)). Proof. apply hΣ. Qed. @@ -562,7 +562,7 @@ Lemma levels_global_constraint {cf : checker_flags} Σ (hΣ : wf Σ) c : /\ LS.In c.2 (global_levels Σ). Proof. intros inc. - destruct hΣ. destruct o. specialize (H c inc). + destruct hΣ. destruct o. specialize (H c inc). destruct c as [[l eq] r]; apply H. Qed. @@ -815,14 +815,14 @@ Definition precompose_subst_instance__1 Rle u i i' Definition precompose_subst_instance__2 Rle u i i' := snd (precompose_subst_instance Rle u i i'). -Lemma subst_instance_level_expr_make u l : +Lemma subst_instance_level_expr_make u l : subst_instance_level_expr u (LevelExpr.make l) = LevelExpr.make (subst_instance_level u l). Proof. destruct l; simpl; auto. rewrite nth_nth_error. now destruct nth_error. Qed. -Lemma subst_instance_make'_make u l : +Lemma subst_instance_make'_make u l : subst_instance u (LevelAlgExpr.make (LevelExpr.make l)) = LevelAlgExpr.make (LevelExpr.make (subst_instance_level u l)). Proof. @@ -910,7 +910,7 @@ Proof. rewrite In_subst_instance. rewrite spec_map_succ. split. * intros [x' [hin eq]]. - subst. + subst. apply spec_map_succ in hin as [y [int eq]]. subst x'. exists (subst_instance u y). split; auto. @@ -924,7 +924,7 @@ Proof. rewrite spec_map_succ. split. - exists y; auto. - destruct y as [[] ?]; cbn; auto. - now destruct nth_error. + now destruct nth_error. Qed. Lemma monomorphic_level_notin_levels_of_udecl s udecl : @@ -965,9 +965,9 @@ Proof. apply sup_subst_instance_univ0. Qed. -Lemma subst_instance_extended_subst u Γ : - subst_instance u (extended_subst Γ 0) = - extended_subst (subst_instance u Γ) 0. +Lemma subst_instance_extended_subst u Γ : + subst_instance u (extended_subst Γ 0) = + extended_subst (subst_instance u Γ) 0. Proof. rewrite /subst_instance /= /subst_instance_list /subst_instance /=. induction Γ as [|[na [b|] ty] Γ]; auto; rewrite /=; len; f_equal; auto. @@ -1058,7 +1058,7 @@ Definition map_constructor_body' f c := Global Instance subst_instance_constructor_body : UnivSubst constructor_body := fun u => map_constructor_body' (subst_instance u). - + Definition map_one_inductive_body' fu f oib := {| ind_name := oib.(ind_name); @@ -1084,19 +1084,19 @@ Definition map_mutual_inductive_body' fu f mib := Global Instance subst_instance_mutual_inductive_body : UnivSubst mutual_inductive_body := fun u => map_mutual_inductive_body' (subst_instance u) (subst_instance u). -Lemma subst_instance_cstr_args u cdecl : +Lemma subst_instance_cstr_args u cdecl : cstr_args (subst_instance u cdecl) = subst_instance u (cstr_args cdecl). Proof. reflexivity. Qed. -Lemma map_fold_context_k {term term' term''} (f : term' -> term) (g : nat -> term'' -> term') (Γ : list (BasicAst.context_decl term'')) : +Lemma map_fold_context_k {term term' term''} (f : term' -> term) (g : nat -> term'' -> term') (Γ : list (BasicAst.context_decl term'')) : map_context f (fold_context_k g Γ) = fold_context_k (fun i => f ∘ (g i)) Γ. Proof. now rewrite /map_context map_fold_context_k. Qed. Lemma subst_instance_subst_context u s k ctx : - subst_instance u (subst_context s k ctx) = + subst_instance u (subst_context s k ctx) = subst_context (subst_instance u s) k (subst_instance u ctx). Proof. rewrite /subst_instance /= /subst_instance /subst_instance_context map_fold_context_k. @@ -1106,7 +1106,7 @@ Proof. Qed. Lemma subst_instance_subst_telescope u s k ctx : - subst_instance u (subst_telescope s k ctx) = + subst_instance u (subst_telescope s k ctx) = subst_telescope (subst_instance u s) k (subst_instance u ctx). Proof. rewrite /subst_instance /= /subst_instance /subst_instance_context /= /subst_telescope /= @@ -1117,7 +1117,7 @@ Proof. Qed. Lemma subst_instance_lift_context u n k ctx : - subst_instance u (lift_context n k ctx) = + subst_instance u (lift_context n k ctx) = lift_context n k (subst_instance u ctx). Proof. rewrite /subst_instance /= /subst_instance_context map_fold_context_k. @@ -1194,14 +1194,14 @@ Proof. Qed. Lemma map2_set_binder_name_map bctx f Γ : - map2 set_binder_name bctx (map_context f Γ) = + map2 set_binder_name bctx (map_context f Γ) = map_context f (map2 set_binder_name bctx Γ). Proof. now rewrite /map_context map_map2 map2_map_r. Qed. Lemma subst_instance_case_branch_context ind mdecl u p bctx cdecl : - subst_instance u (case_branch_context ind mdecl p bctx cdecl) = + subst_instance u (case_branch_context ind mdecl p bctx cdecl) = case_branch_context ind mdecl (subst_instance u p) bctx cdecl. Proof. unfold case_branch_context, case_branch_context_gen. @@ -1212,7 +1212,7 @@ Proof. Qed. Lemma subst_instance_case_predicate_context ind mdecl idecl p u : - subst_instance u (case_predicate_context ind mdecl idecl p) = + subst_instance u (case_predicate_context ind mdecl idecl p) = case_predicate_context ind mdecl idecl (subst_instance u p). Proof. unfold case_predicate_context, case_predicate_context_gen. @@ -1245,7 +1245,7 @@ Proof. Qed. Lemma subst_instance_expand_lets u Γ t : - subst_instance u (expand_lets Γ t) = + subst_instance u (expand_lets Γ t) = expand_lets (subst_instance u Γ) (subst_instance u t). Proof. rewrite /expand_lets /expand_lets_k. @@ -1258,7 +1258,7 @@ Qed. #[global] Hint Rewrite subst_instance_expand_lets closedn_subst_instance : substu. Lemma subst_instance_expand_lets_ctx u Γ Δ : - subst_instance u (expand_lets_ctx Γ Δ) = + subst_instance u (expand_lets_ctx Γ Δ) = (expand_lets_ctx (subst_instance u Γ) (subst_instance u Δ)). Proof. now rewrite /expand_lets_ctx /expand_lets_k_ctx; substu; len. @@ -1271,18 +1271,18 @@ Proof. now rewrite /forget_types map_map_compose /=. Qed. -Lemma subst_instance_case_branch_type {cf : checker_flags} {Σ} {wfΣ : wf Σ} u (ci : case_info) mdecl idecl p predctx br i cdecl : - let ptm := - it_mkLambda_or_LetIn predctx (preturn p) +Lemma subst_instance_case_branch_type {cf : checker_flags} {Σ} {wfΣ : wf Σ} u (ci : case_info) mdecl idecl p predctx br i cdecl : + let ptm := + it_mkLambda_or_LetIn predctx (preturn p) in let p' := subst_instance u p in let ptm' := - it_mkLambda_or_LetIn + it_mkLambda_or_LetIn (subst_instance u predctx) (preturn p') in case_branch_type ci mdecl idecl - (subst_instance u p) - (map_branch (subst_instance u) id br) + (subst_instance u p) + (map_branch (subst_instance u) id br) ptm' i cdecl = map_pair (subst_instance u) (subst_instance u) (case_branch_type ci mdecl idecl p br ptm i cdecl). @@ -1291,7 +1291,7 @@ Proof. rewrite /case_branch_type /case_branch_type_gen /map_pair /=. rewrite subst_instance_case_branch_context //. f_equal; substu. - f_equal. + f_equal. rewrite map_app. f_equal. + rewrite !map_map_compose. apply map_ext => x. substu. @@ -1317,7 +1317,7 @@ Qed. Lemma subst_instance_wf_branch u cdecl br : wf_branch cdecl br -> wf_branch cdecl (map_branch (subst_instance u) id br). -Proof. +Proof. now unfold wf_branch, wf_branch_gen. Qed. @@ -1332,17 +1332,17 @@ Qed. subst_instance_wf_branch subst_instance_wf_branches : pcuic. Lemma subst_instance_predicate_set_pparams u p params : - subst_instance u (set_pparams p params) = + subst_instance u (set_pparams p params) = set_pparams (subst_instance u p) (List.map (subst_instance u) params). Proof. reflexivity. Qed. (* Lemma subst_instance_predicate_set_pcontext u p pcontext : - subst_instance u (set_pcontext p pcontext) = + subst_instance u (set_pcontext p pcontext) = set_pcontext (subst_instance u p) (subst_instance u pcontext). Proof. reflexivity. Qed. *) Lemma subst_instance_predicate_set_preturn u p pret : - subst_instance u (set_preturn p pret) = + subst_instance u (set_preturn p pret) = set_preturn (subst_instance u p) (subst_instance u pret). Proof. reflexivity. Qed. @@ -1364,7 +1364,7 @@ Proof. reflexivity. - cbn. rewrite subst_instance_mkApps. cbn. rewrite iota_red_subst_instance. - change (bcontext br) with (bcotext (map_branch (subst_instance u) br)). + change (bcontext br) with (bcotext (map_branch (subst_instance u) br)). eapply red_iota; eauto with pcuic. * rewrite nth_error_map H //. * simpl. now len. @@ -1374,7 +1374,7 @@ Proof. * inversion H. rewrite nth_error_map E. cbn. destruct d. cbn in *. cbn in *; try congruence. - f_equal. f_equal. + f_equal. f_equal. now rewrite subst_instance_subst fix_subst_instance_subst. * inversion H. + unfold is_constructor in *. @@ -1413,7 +1413,7 @@ Proof. eapply case_red_return; eauto with pcuic. rewrite subst_instance_app in IHX0. now rewrite -inst_case_predicate_context_subst_instance. - - cbn. econstructor; eauto with pcuic. + - cbn. econstructor; eauto with pcuic. * eapply OnOne2_map. eapply OnOne2_impl; [eassumption | pcuicfo]; unfold on_Trel; simpl; intuition eauto. rewrite /map_branch /id. @@ -1620,7 +1620,7 @@ Qed. Lemma in_var_global_ext {cf : checker_flags} n Σ : wf Σ.1 -> - LevelSet.In (Level.Var n) (global_ext_levels Σ) -> + LevelSet.In (Level.Var n) (global_ext_levels Σ) -> LevelSet.In (Level.Var n) (levels_of_udecl Σ.2). Proof. intros wfΣ Hin. @@ -1639,13 +1639,13 @@ Proof. intros [hin|hin] % LevelSet.union_spec. - now eapply monomorphic_level_notin_levels_of_udecl in hin. - apply hin. -Qed. +Qed. Lemma wf_universe_subst_instance {cf : checker_flags} (Σ : global_env_ext) univs u s : wf Σ -> wf_universe Σ s -> consistent_instance_ext (Σ.1, univs) Σ.2 u -> - wf_universe (Σ.1, univs) (subst_instance u s). + wf_universe (Σ.1, univs) (subst_instance u s). Proof. destruct s as [| | t]; cbnr. intros wfΣ Hl Hu e [[l n] [inl ->]]%In_subst_instance. @@ -1678,7 +1678,7 @@ Lemma global_context_set_sub_ext Σ φ : Proof. split. - cbn. unfold global_ext_levels. cbn. - unfold global_levels. + unfold global_levels. intros x hin. apply LevelSet.union_spec; right. now apply LevelSet.union_spec; left. - apply ConstraintSetProp.union_subset_2. @@ -1886,7 +1886,7 @@ Section SubstIdentity. Lemma consistent_instance_ext_subst_abs_inds Σ decl ind u bodies : wf_ext_wk Σ -> consistent_instance_ext Σ decl u -> - subst_instance (abstract_instance Σ.2) (inds ind u bodies) = + subst_instance (abstract_instance Σ.2) (inds ind u bodies) = (inds ind u bodies). Proof using Type. intros wf cu. @@ -1909,14 +1909,14 @@ Section SubstIdentity. 1-2:intros _ l hin%LevelExprSet.singleton_spec; subst l; apply wf_universe_type1; now apply LevelExprSet.singleton_spec. intros Hl. - intros l hin. + intros l hin. eapply Universes.spec_map_succ in hin as [x' [int ->]]. simpl. now specialize (Hl _ int). Qed. - Lemma app_inj {A} (l l' l0 l0' : list A) : + Lemma app_inj {A} (l l' l0 l0' : list A) : #|l| = #|l0| -> - l ++ l' = l0 ++ l0' -> + l ++ l' = l0 ++ l0' -> l = l0 /\ l' = l0'. Proof using Type. induction l in l', l0, l0' |- *; destruct l0; simpl in * => //; auto. @@ -1924,7 +1924,7 @@ Section SubstIdentity. now destruct (IHl _ _ _ eq eql). Qed. - Lemma subst_abstract_instance_id : + Lemma subst_abstract_instance_id : env_prop (fun Σ Γ t T => wf_ext_wk Σ -> let u := abstract_instance (snd Σ) in @@ -1939,14 +1939,14 @@ Section SubstIdentity. * f_equal; auto. unfold map_decl. simpl. unfold vass. f_equal. intuition auto. * unfold map_decl. simpl. unfold vdef. repeat f_equal; intuition auto. } - + 1:{ rewrite subst_instance_lift. f_equal. generalize H. rewrite -H1 /subst_instance /= nth_error_map H /= => [=]. intros Hdecl. now rewrite -{2}Hdecl. } all:try (solve [f_equal; eauto; try congruence]). all:try (rewrite ?subst_instance_two; f_equal; eapply consistent_instance_ext_subst_abs; eauto). - + - now rewrite consistent_instance_ext_subst_abs_univ. - rewrite consistent_instance_ext_subst_abs_univ //. diff --git a/pcuic/theories/Conversion/PCUICWeakeningConv.v b/pcuic/theories/Conversion/PCUICWeakeningConv.v index 927d7c43f..ec8513da0 100644 --- a/pcuic/theories/Conversion/PCUICWeakeningConv.v +++ b/pcuic/theories/Conversion/PCUICWeakeningConv.v @@ -2,8 +2,8 @@ From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction - PCUICLiftSubst PCUICTyping PCUICCumulativity - PCUICClosed PCUICReduction + PCUICLiftSubst PCUICTyping PCUICCumulativity + PCUICClosed PCUICReduction PCUICSigmaCalculus PCUICRenameDef PCUICRenameConv PCUICOnFreeVars PCUICClosedConv PCUICClosedTyp. @@ -68,7 +68,7 @@ Proof. rewrite !lift_context_alt. Qed. Lemma weakening_renaming P Γ Γ' Γ'' : - urenaming P (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (Γ ,,, Γ') + urenaming P (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ') (Γ ,,, Γ') (lift_renaming #|Γ''| #|Γ'|). Proof. intros i d hpi hnth. @@ -81,7 +81,7 @@ Proof. * apply rename_ext => k. rewrite /rshiftk /lift_renaming. repeat nat_compare_specs. * destruct (decl_body d) => /= //. - f_equal. apply rename_ext => k. + f_equal. apply rename_ext => k. rewrite /rshiftk; now nat_compare_specs. - rewrite weaken_nth_error_lt; try lia. rewrite hnth /=. eexists. split; [eauto|]. @@ -325,7 +325,7 @@ Lemma weakening_conv `{cf:checker_flags} : wf Σ.1 -> on_free_vars xpredT M -> on_free_vars xpredT N -> - on_ctx_free_vars xpredT (Γ ,,, Γ') -> + on_ctx_free_vars xpredT (Γ ,,, Γ') -> Σ ;;; Γ ,,, Γ' |- M = N -> Σ ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- lift #|Γ''| #|Γ'| M = lift #|Γ''| #|Γ'| N. Proof. @@ -336,7 +336,7 @@ Proof. now eapply weakening_renaming. Qed. -Lemma isType_on_free_vars {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T} : +Lemma isType_on_free_vars {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T} : isType Σ Γ T -> on_free_vars xpredT T. Proof. intros [s Hs]. @@ -345,7 +345,7 @@ Proof. eapply on_free_vars_impl; tea => //. Qed. -Lemma isType_on_ctx_free_vars {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T} : +Lemma isType_on_ctx_free_vars {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T} : isType Σ Γ T -> on_ctx_free_vars xpredT Γ. Proof. intros [s Hs]. diff --git a/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v b/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v index 6c95a7348..2b94a56e1 100644 --- a/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v +++ b/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v @@ -174,14 +174,14 @@ Lemma weakening_env_cumulSpec0 Σ Σ' φ Γ pb M N : Proof. intros HΣ' Hextends Ind. pose proof (subrelations_leq_extends _ _ φ Hextends). revert H. - assert (RelationClasses.subrelation + assert (RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ,φ))) - (leq_universe (global_ext_constraints (Σ',φ)))). + (leq_universe (global_ext_constraints (Σ',φ)))). { typeclasses eauto. } revert H. - generalize (leq_universe (global_ext_constraints (Σ',φ))); intros Rle Hlee Hle . - revert pb Γ M N Ind Σ' Rle Hle Hlee HΣ' Hextends. + generalize (leq_universe (global_ext_constraints (Σ',φ))); intros Rle Hlee Hle . + revert pb Γ M N Ind Σ' Rle Hle Hlee HΣ' Hextends. apply: (cumulSpec0_ind_all (Σ,φ)). - all:intros; try solve [econstructor; eauto with extends; intuition auto]. + all:intros; try solve [econstructor; eauto with extends; intuition auto]. - eapply cumul_Evar. solve_all. - eapply cumul_Case. * destruct X as (Hparams & Hinst & Hctx & Hret & IHret). repeat split; tas. diff --git a/pcuic/theories/PCUICAlpha.v b/pcuic/theories/PCUICAlpha.v index f5a612243..187fc5f56 100644 --- a/pcuic/theories/PCUICAlpha.v +++ b/pcuic/theories/PCUICAlpha.v @@ -2,9 +2,9 @@ From Coq Require Import ssreflect ssrbool CRelationClasses CMorphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics - PCUICLiftSubst PCUICTyping PCUICWeakeningConv PCUICWeakeningTyp + PCUICLiftSubst PCUICTyping PCUICWeakeningConv PCUICWeakeningTyp PCUICCumulativity PCUICEquality PCUICClosedTyp - PCUICConversion PCUICContextConversion PCUICContextConversionTyp + PCUICConversion PCUICContextConversion PCUICContextConversionTyp PCUICValidity PCUICArities PCUICSpine PCUICInductives PCUICInductiveInversion PCUICOnFreeVars PCUICWellScopedCumulativity PCUICGuardCondition. @@ -704,7 +704,7 @@ Section Alpha. eapply R_universe_instance_eq in eqinst. assert (isType Σ Δ (mkApps ptm (args ++ [c]))). { eapply isType_eq_context_conversion. eapply validity. econstructor; eauto. - constructor; eauto. constructor; eauto. + constructor; eauto. constructor; eauto. solve_all. eapply a0; eauto; reflexivity. all:auto. } eapply type_Cumul'; tea. + have cu' : consistent_instance_ext Σ (ind_universes mdecl) (puinst p'). @@ -753,7 +753,7 @@ Section Alpha. intros ??? [[] ?]; try constructor; simpl; auto; now transitivity na'. } destruct (wf_local_app_inv X4) as [wfΔ _]. assert (clΔ := (wf_local_closed_context wfΔ)). - econstructor; tea; eauto. 2,3: constructor; tea ; eauto. + econstructor; tea; eauto. 2,3: constructor; tea ; eauto. * eapply (type_ws_cumul_pb (pb:=Cumul)). eapply IHc; eauto. eexists; eapply isType_mkApps_Ind; tea. diff --git a/pcuic/theories/PCUICArities.v b/pcuic/theories/PCUICArities.v index c78025c9c..37220c8f9 100644 --- a/pcuic/theories/PCUICArities.v +++ b/pcuic/theories/PCUICArities.v @@ -53,7 +53,7 @@ Inductive typing_spine {cf} Σ (Γ : context) : term -> list term -> term -> Typ Σ ;;; Γ |- hd : A -> typing_spine Σ Γ (subst10 hd B) tl B' -> typing_spine Σ Γ ty (hd :: tl) B'. - + Derive Signature NoConfusion for typing_spine. Lemma typing_spine_isType_codom {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T args U} : @@ -70,7 +70,7 @@ Lemma subslet_inds_gen {cf} {Σ : global_env} {wfΣ : wf Σ} ind mdecl idecl : Proof. intros isdecl u. unfold inds. - pose proof (proj1 isdecl) as declm'. + pose proof (proj1 isdecl) as declm'. apply on_declared_minductive in declm' as [oind oc]; auto. clear oc. assert (Alli (fun i x => @@ -91,7 +91,7 @@ Proof. induction l using rev_ind; simpl; first constructor. rewrite /subst_instance /= /map_context. simpl. rewrite /arities_context rev_map_spec /=. - rewrite map_app /= rev_app_distr /=. + rewrite map_app /= rev_app_distr /=. rewrite /= app_length /= Nat.add_1_r. constructor. - rewrite -rev_map_spec. apply IHl; try lia. @@ -99,7 +99,7 @@ Proof. - eapply Alli_app in X as [oind Hx]. depelim Hx. clear Hx. rewrite Nat.add_0_r in t. - rewrite subst_closedn; auto. + rewrite subst_closedn; auto. + eapply typecheck_closed in t as [? ?]; auto. destruct p as [? ?]. now move/andb_and: i0=> [? ?]. @@ -108,7 +108,7 @@ Qed. Section WfEnv. Context {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}. - Lemma ws_cumul_ctx_pb_vass {Γ Γ' na na' A A'} le : + Lemma ws_cumul_ctx_pb_vass {Γ Γ' na na' A A'} le : eq_binder_annot na na' -> Σ ⊢ Γ ≤[le] Γ' -> Σ ;;; Γ ⊢ A ≤[le] A' -> @@ -117,7 +117,7 @@ Section WfEnv. repeat (constructor; auto). Qed. - Lemma ws_cumul_ctx_pb_app {le Γ Γ' Δ Δ'} : + Lemma ws_cumul_ctx_pb_app {le Γ Γ' Δ Δ'} : #|Δ| = #|Δ'| -> Σ ⊢ Γ ,,, Δ ≤[le] Γ' ,,, Δ' <~> Σ ⊢ Γ ≤[le] Γ' × ws_cumul_ctx_pb_rel le Σ Γ Δ Δ'. @@ -154,7 +154,7 @@ Section WfEnv. cbn. eapply ws_cumul_ctx_pb_refl; eauto with fvs. - destruct ctx using rev_ind. * eapply ws_cumul_pb_Sort_l_inv in HT as [u' [redT leqT]]. - exists (tSort u'), [], u'; split; auto; cbn. + exists (tSort u'), [], u'; split; auto; cbn. apply ws_cumul_ctx_pb_refl; eauto with fvs. * rewrite it_mkProd_or_LetIn_app in HT; simpl in HT. destruct x as [na [b|] ty]; unfold mkProd_or_LetIn in HT; simpl in *. @@ -168,7 +168,7 @@ Section WfEnv. exists T', ctx', s'. split; auto. rewrite smash_context_app. simpl. now rewrite -smash_context_subst_empty. - + eapply ws_cumul_pb_Prod_l_inv in HT; auto. + + eapply ws_cumul_pb_Prod_l_inv in HT; auto. rewrite -> app_length in Hlen. rewrite Nat.add_1_r in Hlen. destruct HT as [na' [A' [B' [redT convT HT]]]]. @@ -204,7 +204,7 @@ Section WfEnv. rewrite shiftnP0 andb_true_r; eauto with fvs. Qed. - Lemma isType_tProd {Γ} {na A B} : + Lemma isType_tProd {Γ} {na A B} : isType Σ Γ (tProd na A B) <~> (isType Σ Γ A × isType Σ (Γ,, vass na A) B). Proof. split; intro HH. @@ -220,7 +220,7 @@ Section WfEnv. Lemma isType_subst {Γ Δ A} s : subslet Σ Γ s Δ -> - isType Σ (Γ ,,, Δ) A -> + isType Σ (Γ ,,, Δ) A -> isType Σ Γ (subst0 s A). Proof using wfΣ. intros sub HT. @@ -231,7 +231,7 @@ Section WfEnv. Lemma isType_subst_gen {Γ Δ Δ'} {A} s : subslet Σ Γ s Δ -> - isType Σ (Γ ,,, Δ ,,, Δ') A -> + isType Σ (Γ ,,, Δ ,,, Δ') A -> isType Σ (Γ ,,, subst_context s 0 Δ') (subst s #|Δ'| A). Proof using wfΣ. intros sub HT. @@ -278,7 +278,7 @@ Section WfEnv. apply inversion_LetIn in H; tas. now destruct H as (s1 & A' & HA & Ht & HB & H). Qed. - Lemma wf_local_ass {Γ na A} : + Lemma wf_local_ass {Γ na A} : wf_local Σ Γ -> isType Σ Γ A -> wf_local Σ (Γ ,, vass na A). @@ -286,7 +286,7 @@ Section WfEnv. constructor; eauto with pcuic. Qed. - Lemma wf_local_def {Γ na d ty} : + Lemma wf_local_def {Γ na d ty} : wf_local Σ Γ -> isType Σ Γ ty -> Σ ;;; Γ |- d : ty -> @@ -298,7 +298,7 @@ Section WfEnv. Hint Resolve wf_local_ass wf_local_def : pcuic. Hint Transparent snoc : pcuic. - Lemma isType_apply {Γ na A B t} : + Lemma isType_apply {Γ na A B t} : isType Σ Γ (tProd na A B) -> Σ ;;; Γ |- t : A -> isType Σ Γ (B {0 := t}). @@ -308,8 +308,8 @@ Section WfEnv. Qed. Hint Resolve isType_wf_local : pcuic. - - Lemma typing_spine_letin_inv {Γ na b B T args S} : + + Lemma typing_spine_letin_inv {Γ na b B T args S} : typing_spine Σ Γ (tLetIn na b B T) args S -> typing_spine Σ Γ (T {0 := b}) args S. Proof using wfΣ. @@ -323,7 +323,7 @@ Section WfEnv. now eapply ws_cumul_pb_LetIn_l_inv in w. Qed. - Lemma typing_spine_letin {Γ na b B T args S} : + Lemma typing_spine_letin {Γ na b B T args S} : isType Σ Γ (tLetIn na b B T) -> typing_spine Σ Γ (T {0 := b}) args S -> typing_spine Σ Γ (tLetIn na b B T) args S. @@ -352,7 +352,7 @@ Section WfEnv. econstructor; eauto. Qed. - Lemma typing_spine_prod {Γ na b B T args S} : + Lemma typing_spine_prod {Γ na b B T args S} : typing_spine Σ Γ (T {0 := b}) args S -> isType Σ Γ (tProd na B T) -> Σ ;;; Γ |- b : B -> @@ -369,24 +369,24 @@ Section WfEnv. econstructor; revgoals; eauto with pcuic. Qed. - Lemma typing_spine_WAT_concl {Γ T args S} : + Lemma typing_spine_WAT_concl {Γ T args S} : typing_spine Σ Γ T args S -> isType Σ Γ S. Proof using Type. induction 1; auto. Qed. - Lemma typing_spine_isType_dom {Γ T args S} : + Lemma typing_spine_isType_dom {Γ T args S} : typing_spine Σ Γ T args S -> isType Σ Γ T. Proof using Type. induction 1; auto. Qed. - Lemma type_mkProd_or_LetIn {Γ} d {u t s} : + Lemma type_mkProd_or_LetIn {Γ} d {u t s} : Σ ;;; Γ |- decl_type d : tSort u -> Σ ;;; Γ ,, d |- t : tSort s -> - match decl_body d return Type with + match decl_body d return Type with | Some b => Σ ;;; Γ |- mkProd_or_LetIn d t : tSort s | None => Σ ;;; Γ |- mkProd_or_LetIn d t : tSort (Universe.sort_of_product u s) end. @@ -402,7 +402,7 @@ Section WfEnv. eapply type_Prod; eauto. Qed. - Lemma type_it_mkProd_or_LetIn {Γ Γ' u t s} : + Lemma type_it_mkProd_or_LetIn {Γ Γ' u t s} : wf_universe Σ u -> type_local_ctx (lift_typing typing) Σ Γ Γ' u -> Σ ;;; Γ ,,, Γ' |- t : tSort s -> @@ -439,7 +439,7 @@ Section WfEnv. | u :: us => sort_of_products us (Universe.sort_of_product u s) end. - Lemma leq_universe_sort_of_products_mon {u u' v v'} : + Lemma leq_universe_sort_of_products_mon {u u' v v'} : Forall2 (leq_universe Σ) u u' -> leq_universe Σ v v' -> leq_universe Σ (sort_of_products u v) (sort_of_products u' v'). @@ -449,7 +449,7 @@ Section WfEnv. eapply leq_universe_product_mon => //. Qed. - Lemma type_it_mkProd_or_LetIn_sorts {Γ Γ' us t s} : + Lemma type_it_mkProd_or_LetIn_sorts {Γ Γ' us t s} : sorts_local_ctx (lift_typing typing) Σ Γ Γ' us -> Σ ;;; Γ ,,, Γ' |- t : tSort s -> Σ ;;; Γ |- it_mkProd_or_LetIn Γ' t : tSort (sort_of_products us s). @@ -463,7 +463,7 @@ Section WfEnv. eapply (type_mkProd_or_LetIn {| decl_body := Some b |}); auto. simpl. exact Hs. * destruct us => //. destruct equ. - simpl. + simpl. eapply IHΓ'; eauto. apply (type_mkProd_or_LetIn {| decl_body := None |}) => /=; eauto. Qed. @@ -476,7 +476,7 @@ Section WfEnv. Hint Extern 4 (_ ;;; _ |- _ <= _) => reflexivity : pcuic. Ltac pcuic := eauto 5 with pcuic. - Lemma subslet_app_closed {Γ s s' Δ Δ'} : + Lemma subslet_app_closed {Γ s s' Δ Δ'} : subslet Σ Γ s Δ -> subslet Σ Γ s' Δ' -> closed_ctx Δ -> @@ -497,9 +497,9 @@ Section WfEnv. Hint Constructors subslet : core pcuic. - Lemma subslet_app_inv {Γ Δ Δ' s} : + Lemma subslet_app_inv {Γ Δ Δ' s} : subslet Σ Γ s (Δ ,,, Δ') -> - subslet Σ Γ (skipn #|Δ'| s) Δ * + subslet Σ Γ (skipn #|Δ'| s) Δ * subslet Σ Γ (firstn #|Δ'| s) (subst_context (skipn #|Δ'| s) 0 Δ'). Proof using Type. intros sub. split. @@ -520,12 +520,12 @@ Section WfEnv. rewrite skipn_S Nat.add_0_r /=. rewrite /subst_decl /map_decl /=. specialize (IHΔ' _ _ sub). - epose proof (cons_let_def _ _ _ _ _ (subst (skipn #|Δ'| s0) #|Δ'| t0) + epose proof (cons_let_def _ _ _ _ _ (subst (skipn #|Δ'| s0) #|Δ'| t0) (subst (skipn #|Δ'| s0) #|Δ'| T) IHΔ'). assert(#|Δ'| = #|firstn #|Δ'| s0|). { pose proof (subslet_length sub). rewrite app_context_length in H. - rewrite firstn_length_le; lia. } + rewrite firstn_length_le; lia. } rewrite {3 6}H in X. rewrite - !subst_app_simpl in X. rewrite !firstn_skipn in X. @@ -545,8 +545,8 @@ Section WfEnv. pose proof (proj1 isdecl) as declm. apply on_declared_minductive in declm as [oind oc]; auto. clear oc. - assert (Alli (fun i x => - Σ ;;; [] |- tInd {| inductive_mind := inductive_mind ind; inductive_ind := i |} u : subst_instance u (ind_type x)) 0 (ind_bodies mdecl)). + assert (Alli (fun i x => + Σ ;;; [] |- tInd {| inductive_mind := inductive_mind ind; inductive_ind := i |} u : subst_instance u (ind_type x)) 0 (ind_bodies mdecl)). { apply forall_nth_error_Alli. econstructor; eauto. split; eauto. simpl. eapply isdecl. } clear oind. @@ -556,7 +556,7 @@ Section WfEnv. induction l using rev_ind; simpl; first constructor. rewrite /subst_instance /= /map_context. simpl. rewrite /arities_context rev_map_spec /=. - rewrite map_app /= rev_app_distr /=. + rewrite map_app /= rev_app_distr /=. rewrite {1}/map_decl /= app_length /= Nat.add_1_r. constructor. - rewrite -rev_map_spec. apply IHl; try lia. @@ -569,7 +569,7 @@ Section WfEnv. Qed. Lemma weaken_subslet {s Δ Γ} : - wf_local Σ Γ -> + wf_local Σ Γ -> subslet Σ [] s Δ -> subslet Σ Γ s Δ. Proof using wfΣ. intros wfΔ. @@ -580,7 +580,7 @@ Section WfEnv. Set Default Goal Selector "1". - Lemma isType_substitution_it_mkProd_or_LetIn {Γ Δ T s} : + Lemma isType_substitution_it_mkProd_or_LetIn {Γ Δ T s} : subslet Σ Γ s Δ -> isType Σ Γ (it_mkProd_or_LetIn Δ T) -> isType Σ Γ (subst0 s T). @@ -603,7 +603,7 @@ Section WfEnv. { rewrite firstn_length_le; lia. } destruct x as [na [b|] ty] => /=; rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=. - + intros Hs. assert (wfs' := typing_wf_universe wfΣ Hs). eapply inversion_LetIn in Hs as (? & ? & ? & ? & ? & ?); auto. @@ -619,7 +619,7 @@ Section WfEnv. eapply type_Cumul. eapply t1. econstructor; intuition eauto using typing_wf_local with pcuic. eapply (cumulAlgo_cumulSpec _ (pb:=Cumul)), w. rewrite {2}Hl in IHn. now rewrite -subst_app_simpl -H0 firstn_skipn in IHn. - + intros Hs. assert (wfs' := typing_wf_universe wfΣ Hs). eapply inversion_Prod in Hs as (? & ? & ? & ? & ?); auto. @@ -633,7 +633,7 @@ Section WfEnv. forward IHn. eapply type_Cumul. simpl in X. eapply X. econstructor; eauto with pcuic. - eapply ws_cumul_pb_Sort_inv in w. eapply cumul_Sort. + eapply ws_cumul_pb_Sort_inv in w. eapply cumul_Sort. transitivity (Universe.sort_of_product x x0). eapply leq_universe_product. auto. rewrite {2}Hl in IHn. @@ -650,7 +650,7 @@ Section WfEnv. now apply onParams in H. Qed. - Lemma it_mkProd_or_LetIn_wf_local {Γ Δ T U} : + Lemma it_mkProd_or_LetIn_wf_local {Γ Δ T U} : Σ ;;; Γ |- it_mkProd_or_LetIn Δ T : U -> wf_local Σ (Γ ,,, Δ). Proof using wfΣ. move: Γ T U. @@ -666,7 +666,7 @@ Section WfEnv. eapply All_local_env_impl; eauto. simpl. intros. now rewrite app_context_assoc. * apply inversion_Prod in H as (s1 & A & H0 & H1 & H2); auto. - eapply All_local_env_app; split; pcuic. + eapply All_local_env_app; split; pcuic. eapply All_local_env_app. split. repeat constructor. now exists s1. apply IHΔ in H1. eapply All_local_env_app_inv in H1. intuition auto. @@ -674,7 +674,7 @@ Section WfEnv. now rewrite app_context_assoc. Qed. - Lemma isType_it_mkProd_or_LetIn_wf_local {Γ Δ T} : + Lemma isType_it_mkProd_or_LetIn_wf_local {Γ Δ T} : isType Σ Γ (it_mkProd_or_LetIn Δ T) -> wf_local Σ (Γ ,,, Δ). Proof using wfΣ. move=> [s Hs]. @@ -696,7 +696,7 @@ Section WfEnv. Qed. Lemma subst_telescope_subst_instance u s k Γ : - subst_telescope (map (subst_instance u) s) k + subst_telescope (map (subst_instance u) s) k (subst_instance u Γ) = subst_instance u (subst_telescope s k Γ). Proof using Type. diff --git a/pcuic/theories/PCUICAst.v b/pcuic/theories/PCUICAst.v index 68b2fc9b1..9f0488591 100644 --- a/pcuic/theories/PCUICAst.v +++ b/pcuic/theories/PCUICAst.v @@ -34,8 +34,8 @@ Notation length_of t := ltac:(let lemma := constr:(PCUICAst.len t) in exact lemm Record predicate {term} := mk_predicate { pparams : list term; (* The parameters *) puinst : Instance.t; (* The universe instance *) - pcontext : list (context_decl term); - (* The predicate context, + pcontext : list (context_decl term); + (* The predicate context, initially built from params and puinst *) preturn : term; (* The return type *) }. Derive NoConfusion for predicate. @@ -47,7 +47,7 @@ Section map_predicate. Context (uf : Instance.t -> Instance.t). Context (paramf preturnf : term -> term'). Context (pcontextf : list (context_decl term) -> list (context_decl term')). - + Definition map_predicate (p : predicate term) := {| pparams := map paramf p.(pparams); puinst := uf p.(puinst); @@ -100,21 +100,21 @@ Section map_predicate_k. Lemma map_k_puinst k (p : predicate term) : uf (puinst p) = puinst (map_predicate_k k p). Proof using Type. reflexivity. Qed. - - Definition test_predicate (instp : Instance.t -> bool) (p : term -> bool) + + Definition test_predicate (instp : Instance.t -> bool) (p : term -> bool) (pred : predicate term) := - instp pred.(puinst) && forallb p pred.(pparams) && + instp pred.(puinst) && forallb p pred.(pparams) && test_context p pred.(pcontext) && p pred.(preturn). - Definition test_predicate_k (instp : Instance.t -> bool) + Definition test_predicate_k (instp : Instance.t -> bool) (p : nat -> term -> bool) k (pred : predicate term) := - instp pred.(puinst) && forallb (p k) pred.(pparams) && + instp pred.(puinst) && forallb (p k) pred.(pparams) && test_context_k p #|pred.(pparams)| pred.(pcontext) && p (#|pred.(pcontext)| + k) pred.(preturn). - Definition test_predicate_ku (instp : nat -> Instance.t -> bool) + Definition test_predicate_ku (instp : nat -> Instance.t -> bool) (p : nat -> term -> bool) k (pred : predicate term) := - instp k pred.(puinst) && forallb (p k) pred.(pparams) && + instp k pred.(puinst) && forallb (p k) pred.(pparams) && test_context (p #|pred.(puinst)|) pred.(pcontext) && p k pred.(preturn). @@ -124,8 +124,8 @@ Section Branch. Context {term : Type}. (* Parameterized by term types as they are not yet defined. *) Record branch := mk_branch { - bcontext : list (context_decl term); - (* Context of binders of the branch, including lets. + bcontext : list (context_decl term); + (* Context of binders of the branch, including lets. This context is open w.r.t. to an instance of the parameters of the inductive type only, it is NOT subject to substitution/lifting *) @@ -138,14 +138,14 @@ Section Branch. Definition pretty_string_of_branch (f : term -> string) (b : branch) := String.concat " " (map (string_of_name ∘ binder_name ∘ decl_name) (bcontext b)) ^ " => " ^ f (bbody b). - + Definition test_branch (pctx : term -> bool) (p : term -> bool) (b : branch) := test_context pctx b.(bcontext) && p b.(bbody). Definition test_branch_k (pred : predicate term) (p : nat -> term -> bool) k (b : branch) := test_context_k p #|pred.(pparams)| b.(bcontext) && p (#|b.(bcontext)| + k) b.(bbody). -End Branch. +End Branch. Arguments branch : clear implicits. Section map_branch. @@ -160,7 +160,7 @@ Section map_branch. Lemma map_bbody (b : branch term) : f (bbody b) = bbody (map_branch b). Proof using Type. reflexivity. Qed. - + Lemma map_bcontext (b : branch term) : g (bcontext b) = bcontext (map_branch b). Proof using Type. reflexivity. Qed. @@ -179,7 +179,7 @@ Section map_branch_k. Lemma map_k_bbody k (b : branch term) : f (#|b.(bcontext)| + k) (bbody b) = bbody (map_branch_k k b). Proof using Type. reflexivity. Qed. - + Lemma map_k_bcontext k (b : branch term) : g (bcontext b) = bcontext (map_branch_k k b). Proof using Type. reflexivity. Qed. @@ -405,7 +405,7 @@ Fixpoint test_context_nlict (bcontext : list (context_decl term)) := End fix_test. -Definition test_branch_nlict test b := +Definition test_branch_nlict test b := test_context_nlict test (bcontext b) && test (bbody b). Definition test_branches_nlict test brs := @@ -454,7 +454,7 @@ Fixpoint noccur_between k n (t : term) : bool := List.forallb (test_def (noccur_between k n) (noccur_between k' n)) mfix | _ => true end. - + (** * Universe substitution Substitution of universe levels for universe level variables, used to @@ -533,13 +533,13 @@ Module PCUICTerm <: Term. Definition subst_instance_constr := subst_instance. End PCUICTerm. -(* These functors derive the notion of local context and lift substitution, term lifting, - the closed predicate to them. *) +(* These functors derive the notion of local context and lift substitution, term lifting, + the closed predicate to them. *) Module PCUICEnvironment := Environment PCUICTerm. Export PCUICEnvironment. (* Do NOT `Include` this module, as this would sadly duplicate the rewrite database... *) - + (** Decompose an arity into a context and a sort *) Fixpoint destArity Γ (t : term) := @@ -577,9 +577,9 @@ Ltac unf_term := unfold PCUICTerm.term in *; unfold PCUICTerm.tRel in *; unfold PCUICTermUtils.destArity in *; unfold PCUICTermUtils.inds in *. -Lemma context_assumptions_mapi_context f (ctx : context) : +Lemma context_assumptions_mapi_context f (ctx : context) : context_assumptions (mapi_context f ctx) = context_assumptions ctx. -Proof. +Proof. now rewrite mapi_context_fold; len. Qed. #[global] @@ -590,7 +590,7 @@ Module PCUICEnvTyping := EnvironmentTyping.EnvTyping PCUICTerm PCUICEnvironment Module PCUICConversion := EnvironmentTyping.Conversion PCUICTerm PCUICEnvironment PCUICTermUtils PCUICEnvTyping. -Global Instance context_reflect`(ReflectEq term) : +Global Instance context_reflect`(ReflectEq term) : ReflectEq (list (BasicAst.context_decl term)) := _. Local Ltac finish := @@ -606,7 +606,7 @@ Local Ltac fcase c := case c ; intro e ; [ subst ; try (left ; reflexivity) | finish ]. Definition string_of_predicate {term} (f : term -> string) (p : predicate term) := - "(" ^ "(" ^ String.concat "," (map f (pparams p)) ^ ")" + "(" ^ "(" ^ String.concat "," (map f (pparams p)) ^ ")" ^ "," ^ string_of_universe_instance (puinst p) ^ ",(" ^ String.concat "," (map (string_of_name ∘ binder_name ∘ decl_name) (pcontext p)) ^ ")" ^ "," ^ f (preturn p) ^ ")". @@ -623,7 +623,7 @@ Definition eqb_predicate_gen (eqb_univ_instance : Instance.t -> Instance.t -> bo Definition eqb_predicate (eqterm : term -> term -> bool) (p p' : predicate term) := eqb_predicate_gen eqb (eqb_context_decl eqterm) eqterm p p'. - + (** Theory of [map] variants on branches and predicates. *) (* The [map] rewrite database gathers all the map composition rewrite lemmas @@ -657,7 +657,7 @@ Proof. Qed. #[global] Hint Rewrite @map_predicate_id : map. - + Definition tCasePredProp_k (P : nat -> term -> Type) k (p : predicate term) := @@ -671,7 +671,7 @@ Definition tCasePredProp {term} onctx Pparams p.(pcontext) × Preturn p.(preturn). -Lemma map_predicate_eq_spec {A B} (finst finst' : Instance.t -> Instance.t) +Lemma map_predicate_eq_spec {A B} (finst finst' : Instance.t -> Instance.t) (f f' g g' : A -> B) h h' (p : predicate A) : finst (puinst p) = finst' (puinst p) -> map f (pparams p) = map g (pparams p) -> @@ -683,7 +683,7 @@ Proof. Qed. #[global] Hint Resolve map_predicate_eq_spec : all. -Lemma map_predicate_k_eq_spec {A} (finst finst' : Instance.t -> Instance.t) +Lemma map_predicate_k_eq_spec {A} (finst finst' : Instance.t -> Instance.t) (f g : nat -> A -> A) k k' (p : predicate A) : finst (puinst p) = finst' (puinst p) -> map (f k) (pparams p) = map (g k') (pparams p) -> @@ -714,7 +714,7 @@ Lemma map_decl_id_spec_cond P p f d : Proof. intros []. unfold map_decl; destruct d; cbn in *. - unfold test_decl; simpl. + unfold test_decl; simpl. intros [pty pbody]%andb_and. intros Hx. f_equal; eauto. destruct decl_body; simpl; eauto. f_equal. @@ -727,7 +727,7 @@ Lemma map_context_id_spec P f ctx : map_context f ctx = ctx. Proof. intros Hc Hf. induction Hc; simpl; auto. - rewrite IHHc. f_equal; eapply map_decl_id_spec; eauto. + rewrite IHHc. f_equal; eapply map_decl_id_spec; eauto. Qed. #[global] Hint Resolve map_context_id_spec : all. @@ -739,7 +739,7 @@ Lemma map_context_id_spec_cond P p f ctx : Proof. intros Hc Hc' Hf. induction Hc in Hc' |- *; simpl; auto. revert Hc'; simpl; intros [hx hl]%andb_and. - rewrite IHHc; auto. f_equal. eapply map_decl_id_spec_cond; eauto. + rewrite IHHc; auto. f_equal. eapply map_decl_id_spec_cond; eauto. Qed. #[global] Hint Resolve map_context_id_spec_cond : all. @@ -767,7 +767,7 @@ Qed. #[global] Hint Resolve map_predicate_k_id_spec : all. #[global] -Instance map_predicate_proper {term} : +Instance map_predicate_proper {term} : Proper (`=1` ==> `=1` ==> `=1` ==> Logic.eq ==> Logic.eq)%signature (@map_predicate term term id). Proof. intros eqf0 eqf1 eqf. @@ -792,7 +792,7 @@ Proof. intros x. unfold shiftf. now rewrite Nat.add_0_r. Qed. #[global] Hint Rewrite @shiftf0 : map. -Lemma map_predicate_k_map_predicate_k +Lemma map_predicate_k_map_predicate_k (finst finst' : Instance.t -> Instance.t) (f f' : nat -> term -> term) k k' (p : predicate term) : @@ -807,7 +807,7 @@ Qed. #[global] Hint Rewrite map_predicate_k_map_predicate_k : map. -Lemma map_predicate_map_predicate_k +Lemma map_predicate_map_predicate_k (finst finst' : Instance.t -> Instance.t) (f : term -> term) (f' : nat -> term -> term) k (p : predicate term) : @@ -823,7 +823,7 @@ Hint Rewrite map_predicate_map_predicate_k : map. Lemma map_predicate_k_map_predicate (finst finst' : Instance.t -> Instance.t) - (f' : term -> term) (f : nat -> term -> term) + (f' : term -> term) (f : nat -> term -> term) k (p : predicate term) : map_predicate_k finst f k (map_predicate finst' f' f' id p) = map_predicate_k (finst ∘ finst') (fun k => (f k) ∘ f') k p. @@ -839,7 +839,7 @@ Lemma map_branch_map_branch {term term' term''} (f : term' -> term'') (f' : term -> term') - h h' + h h' (b : branch term) : map_branch f h (map_branch f' h' b) = map_branch (f ∘ f') (h ∘ h') b. @@ -900,7 +900,7 @@ Hint Rewrite map_branch_k_map_branch : map. Lemma map_branch_id x : map_branch (@id term) id x = id x. Proof. unfold map_branch, id; destruct x; cbn. - f_equal. + f_equal. Qed. #[global] Hint Rewrite @map_branch_id : map. @@ -913,7 +913,7 @@ Proof. destruct d; cbn; intros [Pty Pbod] Hfg. unfold map_decl; cbn in *; f_equal. * destruct decl_body; cbn in *; eauto. f_equal. - eauto. + eauto. * eauto. Qed. @@ -947,7 +947,7 @@ Qed. #[global] Hint Resolve map_branch_eq_spec : all. #[global] -Instance map_branch_proper {term} : Proper (`=1` ==> `=1` ==> Logic.eq ==> Logic.eq) +Instance map_branch_proper {term} : Proper (`=1` ==> `=1` ==> Logic.eq ==> Logic.eq) (@map_branch term term). Proof. intros eqf0 eqf1 eqf h h' eqh'. @@ -1000,7 +1000,7 @@ Lemma map_branches_k_map_branches_k {term term' term''} (f : nat -> term' -> term'') (g : term -> term') - (f' : nat -> term -> term') + (f' : nat -> term -> term') h h' k (l : list (branch term)) : (forall ctx, #|h' ctx| = #|ctx|) -> @@ -1013,7 +1013,7 @@ Proof. simpl; autorewrite with len. now rewrite Hh. Qed. -Lemma case_brs_map_spec {A B} {P : A -> Type} {l} {f g : A -> B} +Lemma case_brs_map_spec {A B} {P : A -> Type} {l} {f g : A -> B} {h h' : list (BasicAst.context_decl A) -> list (BasicAst.context_decl B)} : tCaseBrsProp P l -> (forall x, P x -> f x = g x) -> h =1 h' -> map_branches f h l = map_branches g h' l. @@ -1027,21 +1027,21 @@ Qed. Lemma map_decl_eqP_spec {A B} {P : A -> Type} {p : A -> bool} {d} {f g : A -> B} : ondecl P d -> - test_decl p d -> + test_decl p d -> (forall x, P x -> p x -> f x = g x) -> map_decl f d = map_decl g d. Proof. destruct d; cbn; intros [Pty Pbod] [pty pbody]%andb_and Hfg. unfold map_decl; cbn in *; f_equal. * destruct decl_body; cbn in *; eauto. f_equal. - eauto. + eauto. * eauto. Qed. Lemma map_context_eqP_spec {A B} {P : A -> Type} {p : A -> bool} {ctx} {f g : A -> B} : All (ondecl P) ctx -> - test_context p ctx -> + test_context p ctx -> (forall x, P x -> p x -> f x = g x) -> map_context f ctx = map_context g ctx. Proof. @@ -1093,7 +1093,7 @@ Proof. destruct p0 as [Hty Hbody]. unfold map_decl; destruct x ; cbn in *; f_equal; eauto. destruct decl_body; cbn in *; auto. - f_equal. unfold shiftf. eapply Hfg; auto. + f_equal. unfold shiftf. eapply Hfg; auto. Qed. Lemma test_context_k_eqP_id_spec {A} {P : A -> Type} (p q : nat -> A -> bool) k k' {ctx} : @@ -1135,7 +1135,7 @@ Proof. induction ctx as [|[na [b|] ty] ctx]; simpl; auto; now rewrite IHctx Hfg. Qed. -Lemma test_context_k_eq (p : nat -> term -> bool) n ctx : +Lemma test_context_k_eq (p : nat -> term -> bool) n ctx : test_context_k p n ctx = alli (fun k d => test_decl (p (n + k)) d) 0 (List.rev ctx). Proof. induction ctx; simpl; auto. @@ -1175,14 +1175,14 @@ Proof. Qed. Lemma case_brs_map_spec_cond {A B} {P : A -> Type} pctx p {l} {f g : A -> B} {h h'}: - tCaseBrsProp P l -> + tCaseBrsProp P l -> forallb (test_branch pctx p) l -> (forall x, P x -> p x -> f x = g x) -> (* (forall ctx, onctx P ctx -> test_context pctx ctx -> h ctx = h' ctx) -> *) h =1 h' -> map_branches f h l = map_branches g h' l. Proof. - intros. red in X. + intros. red in X. eapply forallb_All in H. eapply All_map_eq. eapply All_prod in X; tea. clear H. @@ -1216,7 +1216,7 @@ Proof. eapply All_impl. eapply All_prod. exact X. exact H. simpl. intros [bctx bbod] [Hbr hb]. cbn in *. unfold map_branch; cbn. f_equal. - - apply H1. + - apply H1. - eapply H0; eauto. apply Hbr. now move/andb_and: hb => []. Qed. @@ -1231,10 +1231,10 @@ Qed. #[global] Hint Rewrite test_context_map : map. -Lemma onctx_test P (p q : term -> bool) ctx : +Lemma onctx_test P (p q : term -> bool) ctx : onctx P ctx -> test_context p ctx -> - (forall t, P t -> p t -> q t) -> + (forall t, P t -> p t -> q t) -> test_context q ctx. Proof. intros Hc tc HP. revert tc. diff --git a/pcuic/theories/PCUICCSubst.v b/pcuic/theories/PCUICCSubst.v index ef4e52509..c33993b08 100644 --- a/pcuic/theories/PCUICCSubst.v +++ b/pcuic/theories/PCUICCSubst.v @@ -28,7 +28,7 @@ Fixpoint csubst t k u := | tLetIn na b ty b' => tLetIn na (csubst t k b) (csubst t k ty) (csubst t (S k) b') | tCase ind p c brs => let brs' := List.map (fun br => map_branch_k (csubst t) id k br) brs in - tCase ind (map_predicate_k id (csubst t) k p) + tCase ind (map_predicate_k id (csubst t) k p) (csubst t k c) brs' | tProj p c => tProj p (csubst t k c) | tFix mfix idx => @@ -42,11 +42,11 @@ Fixpoint csubst t k u := | x => x end. -(** It is equivalent to general substitution when substituting a closed term *) +(** It is equivalent to general substitution when substituting a closed term *) Lemma closed_subst t k u : closed t -> csubst t k u = subst [t] k u. Proof. - revert k; induction u using term_forall_list_ind; intros k Hs; + revert k; induction u using term_forall_list_ind; intros k Hs; simpl; try f_equal; eauto with pcuic; solve_all. - destruct (PeanoNat.Nat.compare_spec k n). + subst k. @@ -59,7 +59,7 @@ Proof. + now destruct (Nat.leb_spec k n); try lia. Qed. -(** It respects closedness of the substitutend as well. *) +(** It respects closedness of the substitutend as well. *) Lemma closed_csubst t k u : closed t -> closedn (S k) u -> closedn k (csubst t 0 u). Proof. intros. diff --git a/pcuic/theories/PCUICCanonicity.v b/pcuic/theories/PCUICCanonicity.v index 3616c78ee..8b6affc67 100644 --- a/pcuic/theories/PCUICCanonicity.v +++ b/pcuic/theories/PCUICCanonicity.v @@ -771,12 +771,12 @@ Section WeakNormalization. Σ ;;; [] |- t : ty -> False. Proof. eauto using wh_neutral_empty_gen. Qed. - + Require Import Equations.Type.Relation_Properties. (* TODO move *) Lemma invert_red_axiom {Γ cst u cdecl T} : - declared_constant Σ cst cdecl -> + declared_constant Σ cst cdecl -> cst_body cdecl = None -> Σ ;;; Γ ⊢ tConst cst u ⇝ T -> T = tConst cst u. @@ -792,7 +792,7 @@ Section WeakNormalization. Qed. Lemma ws_cumul_pb_Axiom_l_inv {pb Γ cst u cdecl T} : - declared_constant Σ cst cdecl -> + declared_constant Σ cst cdecl -> cst_body cdecl = None -> Σ ;;; Γ ⊢ tConst cst u ≤[pb] T -> ∑ u', Σ ;;; Γ ⊢ T ⇝ tConst cst u' × PCUICEquality.R_universe_instance (eq_universe Σ) u u'. @@ -805,7 +805,7 @@ Section WeakNormalization. Qed. Lemma invert_cumul_axiom_ind {Γ cst cdecl u ind u' args} : - declared_constant Σ cst cdecl -> + declared_constant Σ cst cdecl -> cst_body cdecl = None -> Σ ;;; Γ ⊢ tConst cst u ≤ mkApps (tInd ind u') args -> False. Proof using wfΣ. @@ -814,7 +814,7 @@ Section WeakNormalization. Qed. Lemma invert_cumul_axiom_prod {Γ cst cdecl u na dom codom} : - declared_constant Σ cst cdecl -> + declared_constant Σ cst cdecl -> cst_body cdecl = None -> Σ ;;; Γ ⊢ tConst cst u ≤ tProd na dom codom -> False. Proof using wfΣ. @@ -844,7 +844,7 @@ Section WeakNormalization. - now rewrite head_mkApps /head /=. - eapply inversion_Prim in typed as [prim_ty [cdecl [? ? ? [? hp]]]]; eauto. eapply invert_cumul_axiom_ind in w; eauto. - apply hp. + apply hp. Qed. Lemma whnf_ind_finite t ind u indargs : @@ -1077,7 +1077,7 @@ Section WeakNormalization. specialize (IHHe1 _ Hf). specialize (IHHe2 _ Ha). rewrite mkApps_app /=. now eapply red_app. - + - eapply inversion_App in Ht as (? & ? & ? & Hf & Ha & Ht); auto. specialize (IHHe1 _ Hf). specialize (IHHe2 _ Ha). diff --git a/pcuic/theories/PCUICCasesContexts.v b/pcuic/theories/PCUICCasesContexts.v index a8c830765..07593e1f0 100644 --- a/pcuic/theories/PCUICCasesContexts.v +++ b/pcuic/theories/PCUICCasesContexts.v @@ -4,9 +4,9 @@ From Coq Require Import Utf8 ssreflect ssrbool. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction PCUICLiftSubst PCUICEquality PCUICSigmaCalculus. - + Require Import Equations.Type.Relation_Properties. -Require Import Equations.Prop.DepElim. +Require Import Equations.Prop.DepElim. From Equations Require Import Equations. Local Set SimplIsCbn. @@ -25,7 +25,7 @@ Proof. Qed. Notation eq_names := (All2 (fun x y => x = (decl_name y))). -Lemma eq_names_subst_context nas Γ s k : +Lemma eq_names_subst_context nas Γ s k : eq_names nas Γ -> eq_names nas (subst_context s k Γ). Proof. @@ -34,7 +34,7 @@ Proof. * rewrite subst_context_snoc. constructor; auto. Qed. -Lemma eq_names_subst_instance nas Γ u : +Lemma eq_names_subst_instance nas Γ u : eq_names nas Γ -> eq_names nas (subst_instance u Γ). Proof. @@ -46,7 +46,7 @@ Qed. (* Lemma All2_compare_decls_subst pars n Γ i : eq_context_upto_names (subst_context pars n Γ@[i]) (subst_context pars n Γ'@[i]) eq_context_upto_names (subst_context pars n Γ@[i]) (subst_context pars n Γ'@[i]) *) -Lemma alpha_eq_subst_instance Δ Δ' i : +Lemma alpha_eq_subst_instance Δ Δ' i : eq_context_upto_names Δ Δ' -> eq_context_upto_names Δ@[i] Δ'@[i]. Proof. @@ -57,7 +57,7 @@ Proof. Qed. -Lemma alpha_eq_context_assumptions Δ Δ' : +Lemma alpha_eq_context_assumptions Δ Δ' : eq_context_upto_names Δ Δ' -> context_assumptions Δ = context_assumptions Δ'. Proof. @@ -65,7 +65,7 @@ Proof. destruct r; simpl; auto; lia. Qed. -Lemma alpha_eq_extended_subst Δ Δ' k : +Lemma alpha_eq_extended_subst Δ Δ' k : eq_context_upto_names Δ Δ' -> extended_subst Δ k = extended_subst Δ' k. Proof. @@ -74,7 +74,7 @@ Proof. rewrite IHX (alpha_eq_context_assumptions l l') //. Qed. -Lemma alpha_eq_smash_context Δ Δ' : +Lemma alpha_eq_smash_context Δ Δ' : eq_context_upto_names Δ Δ' -> eq_context_upto_names (smash_context [] Δ) (smash_context [] Δ'). Proof. @@ -86,7 +86,7 @@ Proof. rewrite (All2_length X) -(alpha_eq_extended_subst l l' 0) // (alpha_eq_context_assumptions l l') //. Qed. -Lemma alpha_eq_lift_context n k Δ Δ' : +Lemma alpha_eq_lift_context n k Δ Δ' : eq_context_upto_names Δ Δ' -> eq_context_upto_names (lift_context n k Δ) (lift_context n k Δ'). Proof. @@ -97,7 +97,7 @@ Proof. now rewrite (All2_length X). Qed. -Lemma alpha_eq_subst_context s k Δ Δ' : +Lemma alpha_eq_subst_context s k Δ Δ' : eq_context_upto_names Δ Δ' -> eq_context_upto_names (subst_context s k Δ) (subst_context s k Δ'). Proof. @@ -110,14 +110,14 @@ Qed. Lemma inst_case_predicate_context_eq {mdecl idecl ind p} : eq_context_upto_names p.(pcontext) (ind_predicate_context ind mdecl idecl) -> - case_predicate_context ind mdecl idecl p = + case_predicate_context ind mdecl idecl p = inst_case_predicate_context p. Proof. intros a. eapply map2_set_binder_name_alpha_eq. { eapply eq_names_subst_context, eq_names_subst_instance. eapply All2_map_left. eapply All2_refl. reflexivity. } - { apply alpha_eq_subst_context, alpha_eq_subst_instance. + { apply alpha_eq_subst_context, alpha_eq_subst_instance. now symmetry. } Qed. @@ -136,7 +136,7 @@ Definition case_predicate_context' ind mdecl idecl p := (subst_instance p.(puinst) (expand_lets_ctx (ind_params mdecl) (ind_indices idecl))). -Lemma eq_binder_annots_eq nas Γ : +Lemma eq_binder_annots_eq nas Γ : All2 (fun x y => eq_binder_annot x y.(decl_name)) nas Γ -> eq_context_upto_names (map2 set_binder_name nas Γ) Γ. Proof. @@ -145,7 +145,7 @@ Proof. Qed. -Definition pre_case_branch_context (ind : inductive) (mdecl : mutual_inductive_body) +Definition pre_case_branch_context (ind : inductive) (mdecl : mutual_inductive_body) (params : list term) (puinst : Instance.t) (cdecl : constructor_body) := subst_context (List.rev params) 0 (expand_lets_ctx (subst_instance puinst (ind_params mdecl)) @@ -173,14 +173,14 @@ Proof. induction 1; rewrite ?subst_context_snoc //; constructor; auto. Qed. -Lemma inst_case_branch_context_eq {ind mdecl cdecl p br} : +Lemma inst_case_branch_context_eq {ind mdecl cdecl p br} : eq_context_upto_names br.(bcontext) (cstr_branch_context ind mdecl cdecl) -> case_branch_context ind mdecl p (forget_types br.(bcontext)) cdecl = inst_case_branch_context p br. Proof. intros. rewrite /case_branch_context /case_branch_context_gen. rewrite /inst_case_branch_context /inst_case_context. - eapply map2_set_binder_name_alpha_eq. + eapply map2_set_binder_name_alpha_eq. eapply eq_names_subst_context, eq_names_subst_instance. eapply All2_map_left. eapply All2_refl. reflexivity. rewrite /pre_case_branch_context_gen /inst_case_context. diff --git a/pcuic/theories/PCUICConfluence.v b/pcuic/theories/PCUICConfluence.v index 1e09e3bdc..00479289e 100644 --- a/pcuic/theories/PCUICConfluence.v +++ b/pcuic/theories/PCUICConfluence.v @@ -4,16 +4,16 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICOnOne PCUICAstUtils PCUICTactics PCUICReduction PCUICEquality PCUICUnivSubstitutionConv PCUICSigmaCalculus PCUICContextReduction PCUICParallelReduction PCUICParallelReductionConfluence PCUICClosedConv PCUICClosedTyp - PCUICRedTypeIrrelevance PCUICOnFreeVars PCUICInstDef PCUICInstConv PCUICWeakeningConv PCUICWeakeningTyp. + PCUICRedTypeIrrelevance PCUICOnFreeVars PCUICInstDef PCUICInstConv PCUICWeakeningConv PCUICWeakeningTyp. (* We show that conversion/cumulativity starting from well-typed terms is transitive. - We first use typing to decorate the reductions/comparisons with invariants + We first use typing to decorate the reductions/comparisons with invariants showing that all the considered contexts/terms are well-scoped. In a second step - we use confluence of reduction on well-scoped terms [ws_red_confluence], which also + we use confluence of reduction on well-scoped terms [ws_red_confluence], which also commutes with alpha,universe-equivalence of contexts and terms [red1_eq_context_upto_l]. We can drop the invariants on free variables at each step as reduction preserves free-variables, - so we also have [red_confluence]: as long as the starting contexts and terms are well-scoped + so we also have [red_confluence]: as long as the starting contexts and terms are well-scoped confluence holds. *) Require Import ssreflect ssrbool. @@ -30,25 +30,25 @@ Instance red_Refl Σ Γ : Reflexive (red Σ Γ) := refl_red Σ Γ. Instance red_Trans Σ Γ : Transitive (red Σ Γ) := red_trans Σ Γ. #[global] -Instance All_decls_refl P : +Instance All_decls_refl P : Reflexive P -> Reflexive (All_decls P). Proof. intros hP d; destruct d as [na [b|] ty]; constructor; auto. Qed. - + #[global] -Instance All_decls_sym P : +Instance All_decls_sym P : Symmetric P -> Symmetric (All_decls P). Proof. intros hP d d' []; constructor; now symmetry. Qed. #[global] -Instance All_decls_trans P : +Instance All_decls_trans P : Transitive P -> Transitive (All_decls P). Proof. intros hP d d' d'' [] h; depelim h; constructor; now etransitivity. Qed. #[global] -Instance All_decls_equivalence P : +Instance All_decls_equivalence P : Equivalence P -> Equivalence (All_decls P). Proof. @@ -56,7 +56,7 @@ Proof. Qed. #[global] -Instance All_decls_preorder P : +Instance All_decls_preorder P : PreOrder P -> PreOrder (All_decls P). Proof. @@ -64,25 +64,25 @@ Proof. Qed. #[global] -Instance All_decls_alpha_refl P : +Instance All_decls_alpha_refl P : Reflexive P -> Reflexive (All_decls_alpha P). Proof. intros hP d; destruct d as [na [b|] ty]; constructor; auto. Qed. - + #[global] -Instance All_decls_alpha_sym P : +Instance All_decls_alpha_sym P : Symmetric P -> Symmetric (All_decls_alpha P). Proof. intros hP d d' []; constructor; now symmetry. Qed. #[global] -Instance All_decls_alpha_trans P : +Instance All_decls_alpha_trans P : Transitive P -> Transitive (All_decls_alpha P). Proof. intros hP d d' d'' [] h; depelim h; constructor; now etransitivity. Qed. #[global] -Instance All_decls_alpha_equivalence P : +Instance All_decls_alpha_equivalence P : Equivalence P -> Equivalence (All_decls_alpha P). Proof. @@ -111,7 +111,7 @@ Proof. eapply transitivity. eauto. auto. Qed. -Lemma All2_fold_refl {A} {P : list A -> list A -> A -> A -> Type} : +Lemma All2_fold_refl {A} {P : list A -> list A -> A -> A -> Type} : (forall Γ, Reflexive (P Γ Γ)) -> Reflexive (All2_fold P). Proof. @@ -119,7 +119,7 @@ Proof. apply All2_fold_refl; intros. apply HR. Qed. -Lemma OnOne2_prod {A} (P Q : A -> A -> Type) l l' : +Lemma OnOne2_prod {A} (P Q : A -> A -> Type) l l' : OnOne2 P l l' × OnOne2 Q l l' -> (forall x, Q x x) -> OnOne2 (fun x y => P x y × Q x y) l l'. @@ -131,21 +131,21 @@ Proof. auto. Qed. -Lemma OnOne2_prod_assoc {A} (P Q R : A -> A -> Type) l l' : +Lemma OnOne2_prod_assoc {A} (P Q R : A -> A -> Type) l l' : OnOne2 (fun x y => (P x y × Q x y) × R x y) l l' -> OnOne2 P l l' × OnOne2 (fun x y => Q x y × R x y) l l'. Proof. induction 1; split; constructor; intuition eauto. Qed. -Lemma OnOne2_apply {A B} (P : B -> A -> A -> Type) l l' : +Lemma OnOne2_apply {A B} (P : B -> A -> A -> Type) l l' : OnOne2 (fun x y => forall a : B, P a x y) l l' -> forall a : B, OnOne2 (P a) l l'. Proof. induction 1; constructor; auto. Qed. -Lemma OnOne2_apply_All {A} (Q : A -> Type) (P : A -> A -> Type) l l' : +Lemma OnOne2_apply_All {A} (Q : A -> Type) (P : A -> A -> Type) l l' : OnOne2 (fun x y => Q x -> P x y) l l' -> All Q l -> OnOne2 P l l'. @@ -154,7 +154,7 @@ Proof. now depelim X. now depelim X0. Qed. -Lemma OnOne2_sigma {A B} (P : B -> A -> A -> Type) l l' : +Lemma OnOne2_sigma {A B} (P : B -> A -> A -> Type) l l' : OnOne2 (fun x y => ∑ a : B, P a x y) l l' -> ∑ a : B, OnOne2 (P a) l l'. Proof. @@ -164,7 +164,7 @@ Proof. Qed. Lemma OnOne2_local_env_apply {B} {P : B -> context -> term -> term -> Type} {l l'} - (f : context -> term -> term -> B) : + (f : context -> term -> term -> B) : OnOne2_local_env (on_one_decl (fun Γ x y => forall a : B, P a Γ x y)) l l' -> OnOne2_local_env (on_one_decl (fun Γ x y => P (f Γ x y) Γ x y)) l l'. Proof. @@ -172,7 +172,7 @@ Proof. intros Δ x y. eapply on_one_decl_impl; intros Γ ? ?; eauto. Qed. -Lemma OnOne2_local_env_apply_dep {B : context -> term -> term -> Type} +Lemma OnOne2_local_env_apply_dep {B : context -> term -> term -> Type} {P : context -> term -> term -> Type} {l l'} : (forall Γ' x y, B Γ' x y) -> OnOne2_local_env (on_one_decl (fun Γ x y => B Γ x y -> P Γ x y)) l l' -> @@ -203,11 +203,11 @@ Proof. eexists; split; constructor; red; cbn; eauto. - destruct p; subst. destruct s as [[p ->]|[p ->]]; specialize (Hp _ _ _ p) as [? []]; - eexists; split; constructor; red; cbn; eauto. + eexists; split; constructor; red; cbn; eauto. - exists (d :: IHo.π1). split; constructor; auto; apply IHo.π2. Qed. -Lemma OnOne2_local_env_All2_fold (P : context -> term -> term -> Type) +Lemma OnOne2_local_env_All2_fold (P : context -> term -> term -> Type) (Q : context -> context -> context_decl -> context_decl -> Type) (l l' : context) : OnOne2_local_env (on_one_decl P) l l' -> @@ -239,18 +239,18 @@ Lemma OnOne2_disj {A} (P Q : A -> A -> Type) (l l' : list A) : Proof. split. - induction 1; [destruct p|destruct IHX]; try solve [(left + right); constructor; auto]. - - intros []; eapply OnOne2_impl; tea; eauto. + - intros []; eapply OnOne2_impl; tea; eauto. Qed. -Notation red1_ctx_rel Σ Δ := +Notation red1_ctx_rel Σ Δ := (OnOne2_local_env (on_one_decl (fun (Γ : context) (x0 y0 : term) => red1 Σ (Δ,,, Γ) x0 y0))). -Notation eq_one_decl Σ Re Rle := +Notation eq_one_decl Σ Re Rle := (OnOne2_local_env (on_one_decl - (fun _ (x0 y0 : term) => + (fun _ (x0 y0 : term) => eq_term_upto_univ Σ Re Rle x0 y0))). Lemma red1_eq_context_upto_l {Σ Σ' Rle Re Γ Δ u v} : @@ -323,7 +323,7 @@ Proof. - specialize (IHh (Δ ,,, PCUICCases.inst_case_predicate_context p)). forward IHh. eapply eq_context_upto_cat => //. - now apply eq_context_upto_refl. + now apply eq_context_upto_refl. destruct IHh as [? [? ?]]. eexists. split. + solve [ econstructor ; eauto ]. @@ -337,7 +337,7 @@ Proof. * now eapply All2_same. * eapply All2_same. split; reflexivity. - eapply (OnOne2_impl (Q:=fun x y => (∑ v', _) × bcontext x = bcontext y)) in X; tea. - 2:{ intros x y [[red IH] eq]. split; tas. + 2:{ intros x y [[red IH] eq]. split; tas. specialize (IH (Δ ,,, inst_case_branch_context p x)). forward IH by now apply eq_context_upto_cat. exact IH. } eapply (OnOne2_exist' _ (fun x y => on_Trel_eq (red1 Σ (Δ ,,, inst_case_branch_context p x)) bbody bcontext x y) @@ -426,7 +426,7 @@ Proof. All2 (fun x y => eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) * eq_term_upto_univ Σ' Re Re (dbody x) (dbody y) * - (rarg x = rarg y) * + (rarg x = rarg y) * eq_binder_annot (dname x) (dname y))%type mfix1 mfix'). { (* Maybe we should use a lemma using firstn or skipn to keep fix_context intact. Anything general? @@ -537,7 +537,7 @@ Proof. All2 (fun x y => eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) * eq_term_upto_univ Σ' Re Re (dbody x) (dbody y) * - (rarg x = rarg y) * + (rarg x = rarg y) * eq_binder_annot (dname x) (dname y))%type mfix1 mfix'). { (* Maybe we should use a lemma using firstn or skipn to keep fix_context intact. Anything general? @@ -609,7 +609,7 @@ Lemma eq_context_gen_context_assumptions {eq leq Γ Δ} : context_assumptions Γ = context_assumptions Δ. Proof. induction 1; simpl; auto; - destruct p => /= //; try lia. + destruct p => /= //; try lia. Qed. Lemma eq_context_extended_subst {Σ Re Rle Γ Δ k} : @@ -669,7 +669,7 @@ Lemma red1_eq_context_upto_univ_l {Σ Σ' Re Rle Γ ctx ctx' ctx''} : red1_ctx_rel Σ Γ ctx' pctx * eq_context_gen (eq_term_upto_univ Σ' Re Re) (eq_term_upto_univ Σ' Re Re) ctx'' pctx. Proof. - intros. + intros. rename X into e, X0 into X. induction X in e, ctx' |- *. - red in p. simpl in p. @@ -755,7 +755,7 @@ Lemma eq_term_upto_univ_subst_instance' {cf:checker_flags} Σ Re Rle : RelationClasses.Reflexive Re -> SubstUnivPreserving Re -> RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> + RelationClasses.Transitive Rle -> RelationClasses.subrelation Re Rle -> SubstUnivPreserved (fun _ => Re) -> SubstUnivPreserved (fun _ => Rle) -> @@ -911,7 +911,7 @@ Proof. have lenctxass := eq_context_gen_context_assumptions eqctx. have lenctx := All2_fold_length eqctx. eexists. split. - + constructor; tea. + + constructor; tea. epose proof (All2_length h2). congruence. + unfold iota_red. eapply eq_term_upto_univ_substs => //. @@ -927,7 +927,7 @@ Proof. rewrite /inst_case_branch_context. eapply eq_context_upto_subst_context; tc. eapply eq_context_upto_univ_subst_instance'. - 7,8:tea. all:tc. apply e. + 7,8:tea. all:tc. apply e. now eapply All2_rev, e. } now eapply All2_rev, All2_skipn. - apply eq_term_upto_univ_napp_mkApps_l_inv in e as [? [? [[h1 h2] h3]]]. subst. @@ -952,7 +952,7 @@ Proof. eapply isConstruct_app_eq_term_l ; eassumption. + eapply eq_term_upto_univ_napp_mkApps. * eapply eq_term_upto_univ_substs ; eauto. - -- eapply (eq_term_upto_univ_leq _ _ _ 0) ; eauto with arith. + -- eapply (eq_term_upto_univ_leq _ _ _ 0) ; eauto with arith. -- unfold fix_subst. apply All2_length in a as el. rewrite <- el. generalize #|mfix|. intro n. @@ -1068,7 +1068,7 @@ Proof. destruct (IHX _ a0) as [? [? ?]]. eexists. split. + eapply OnOne2_tl. eassumption. - + constructor. all: eauto. + + constructor. all: eauto. } destruct h as [pars0 [? ?]]. eexists. split. @@ -1085,10 +1085,10 @@ Proof. rewrite /inst_case_predicate_context /inst_case_context. eapply eq_context_upto_subst_context; tc. eapply eq_context_upto_univ_subst_instance'. - 7,8:tea. all:tc. + 7,8:tea. all:tc. now eapply All2_rev. } eapply eq_context_upto_refl; tc. } - all:tc. + all:tc. destruct red as [ret' [redret eqret]]. eexists; split. + eapply case_red_return; tea. @@ -1099,7 +1099,7 @@ Proof. - depelim e. eapply OnOne2_prod_assoc in X as [_ X]. assert (h : ∑ brs0, - OnOne2 (fun br br' => + OnOne2 (fun br br' => on_Trel_eq (red1 Σ (Γ ,,, inst_case_branch_context p' br)) bbody bcontext br br') brs' brs0 * All2 (fun x y => eq_context_gen eq eq (bcontext x) (bcontext y) * @@ -1112,7 +1112,7 @@ Proof. eapply p2 in h2 as hh ; eauto. destruct hh as [? [? ?]]. eapply (red1_eq_context_upto_l (Re:=Re) (Rle:=Rle) (Δ := Γ ,,, inst_case_branch_context p' y)) in r; cycle -1. - { eapply eq_context_upto_cat; tea. reflexivity. + { eapply eq_context_upto_cat; tea. reflexivity. rewrite /inst_case_branch_context /inst_case_context. eapply eq_context_upto_subst_context; tc. eapply eq_context_upto_univ_subst_instance'. 7,8:tea. all:tc. @@ -1134,8 +1134,8 @@ Proof. destruct h as [brs0 [? ?]]. eexists. split. * eapply case_red_brs; tea. - * constructor. all: eauto. - + * constructor. all: eauto. + - dependent destruction e. assert (h : ∑ args, OnOne2 (red1 Σ Γ) args' args * @@ -1170,7 +1170,7 @@ Proof. All2 (fun x y => eq_term_upto_univ Σ' Re Re x.(dtype) y.(dtype) * eq_term_upto_univ Σ' Re Re x.(dbody) y.(dbody) * - (x.(rarg) = y.(rarg)) * + (x.(rarg) = y.(rarg)) * eq_binder_annot (dname x) (dname y))%type mfix1 mfix ). { induction X in a, mfix' |- *. @@ -1206,7 +1206,7 @@ Proof. All2 (fun x y => eq_term_upto_univ Σ' Re Re x.(dtype) y.(dtype) * eq_term_upto_univ Σ' Re Re x.(dbody) y.(dbody) * - (x.(rarg) = y.(rarg)) * + (x.(rarg) = y.(rarg)) * eq_binder_annot (dname x) (dname y)) mfix1 mfix ). { revert mfix' a. @@ -1364,7 +1364,7 @@ Proof. All2 (fun x y => eq_term_upto_univ Σ' Re Re x.(dtype) y.(dtype) * eq_term_upto_univ Σ' Re Re x.(dbody) y.(dbody) * - (x.(rarg) = y.(rarg)) * + (x.(rarg) = y.(rarg)) * eq_binder_annot (dname x) (dname y) ) mfix1 mfix ). @@ -1478,7 +1478,7 @@ Proof. Qed. -Lemma Forall2_flip {A} (R : A -> A -> Prop) (x y : list A) : +Lemma Forall2_flip {A} (R : A -> A -> Prop) (x y : list A) : Forall2 (flip R) y x -> Forall2 R x y. Proof. induction 1; constructor; auto. @@ -1615,7 +1615,7 @@ Lemma local_env_telescope P Γ Γ' Δ Δ' : Proof. induction 1. simpl. constructor. - depelim p. simpl. eapply on_contexts_over_app. repeat constructor => //. - simpl. + simpl. revert IHX. generalize (List.rev Δ) (List.rev Δ'). induction 1. constructor. constructor; auto. depelim p0; constructor; auto; @@ -1624,7 +1624,7 @@ Proof. simpl. depelim p. revert IHX. generalize (List.rev Δ) (List.rev Δ'). induction 1. constructor. - constructor; auto. depelim p1; constructor; auto; + constructor; auto. depelim p1; constructor; auto; now rewrite !app_context_assoc. Qed. @@ -1701,7 +1701,7 @@ Proof. all:pcuic. Qed. -Lemma on_free_vars_ctx_closed_xpredT n ctx : +Lemma on_free_vars_ctx_closed_xpredT n ctx : on_free_vars_ctx (closedP n xpredT) ctx -> on_free_vars_ctx xpredT ctx. Proof. @@ -1768,17 +1768,17 @@ Qed. Ltac inv_on_free_vars_xpredT := match goal with - | [ H : is_true (on_free_vars (shiftnP _ _) _) |- _ ] => + | [ H : is_true (on_free_vars (shiftnP _ _) _) |- _ ] => rewrite -> shiftnP_xpredT in H - | [ H : is_true (_ && _) |- _ ] => + | [ H : is_true (_ && _) |- _ ] => move/andP: H => []; intros - | [ H : is_true (on_free_vars ?P ?t) |- _ ] => + | [ H : is_true (on_free_vars ?P ?t) |- _ ] => progress (cbn in H || rewrite -> on_free_vars_mkApps in H); - (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || + (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || eapply forallb_All in H); intros | [ H : is_true (test_def (on_free_vars ?P) ?Q ?x) |- _ ] => - let H0 := fresh in let H' := fresh in - move/andP: H => [H0 H']; + let H0 := fresh in let H' := fresh in + move/andP: H => [H0 H']; try rewrite -> shiftnP_xpredT in H0; try rewrite -> shiftnP_xpredT in H'; intros @@ -1856,7 +1856,7 @@ Section RedPred. now replace #|Δ'| with #|Δ| by lia. Qed. - Lemma pred1_ctx_assumption_context Γ Γ' : + Lemma pred1_ctx_assumption_context Γ Γ' : pred1_ctx Σ Γ Γ' -> assumption_context Γ -> assumption_context Γ'. Proof using Type. @@ -1864,7 +1864,7 @@ Section RedPred. intros h; depelim h. depelim p; constructor; auto. Qed. - Lemma pred1_ctx_over_assumption_context Γ Γ' Δ Δ' : + Lemma pred1_ctx_over_assumption_context Γ Γ' Δ Δ' : pred1_ctx_over Σ Γ Γ' Δ Δ' -> assumption_context Δ -> assumption_context Δ'. Proof using Type. @@ -1885,7 +1885,7 @@ Section RedPred. { apply pred1_pred1_ctx in X. apply on_contexts_app_inv in X as [] => //. apply All2_fold_app => //. now eapply pred1_ctx_over_refl_gen. } - assert(lenΔ : #|Δ| = #|Δ'|). + assert(lenΔ : #|Δ| = #|Δ'|). { eapply pred1_pred1_ctx in X. eapply All2_fold_length in X. rewrite !app_context_length in X. lia. } epose proof (fst strong_substitutivity _ _ _ _ X _ _ (Γ ,,, Δ) (Γ' ,,, Δ) ids ids ont). @@ -1906,7 +1906,7 @@ Section RedPred. eapply nth_error_pred1_ctx_l in predΓ; tea. 2:erewrite hnth => //. destruct predΓ as [body' [hnth' pred]]. - replace #|Δ'| with #|Δ| by lia. + replace #|Δ'| with #|Δ| by lia. exists body'; split=> //. rewrite -lift0_inst /ids /=. econstructor => //. @@ -1935,7 +1935,7 @@ Section RedPred. - constructor; simpl; subst; intuition auto. eapply pred1_refl. - eapply (All2_fold_app (Γ' := [d]) (Γr := [_])); pcuic. - destruct d as [na [b|] ty]; constructor; pcuic. + destruct d as [na [b|] ty]; constructor; pcuic. constructor; simpl; subst; auto; intuition pcuic. eapply pred1_refl_gen. eapply All2_fold_app; pcuic. apply IHX. eapply pred1_refl_gen. eapply All2_fold_app; pcuic. apply IHX. @@ -1949,7 +1949,7 @@ Section RedPred. intuition. Qed. - Lemma red1_pred1 Γ M N : + Lemma red1_pred1 Γ M N : on_ctx_free_vars xpredT Γ -> on_free_vars xpredT M -> red1 Σ Γ M N -> pred1 Σ Γ Γ M N. @@ -1962,7 +1962,7 @@ Section RedPred. - eapply OnOne2_prod_inv in X as []. eapply OnOne2_apply in o0 => //. eapply OnOne2_apply_All in o0 => //. 2:solve_all. - assert (pred1_ctx_over Σ Γ Γ (PCUICCases.inst_case_predicate_context p) + assert (pred1_ctx_over Σ Γ Γ (PCUICCases.inst_case_predicate_context p) (PCUICCases.inst_case_predicate_context (set_pparams p params'))). eapply OnOne2_pars_pred1_ctx_over => //. eauto with fvs. econstructor; pcuic; eauto 6 with fvs. @@ -1974,9 +1974,9 @@ Section RedPred. eapply OnOne2_pars_pred1_ctx_over => //; eauto with fvs; solve_all. - econstructor; pcuic. solve_all. unfold inst_case_branch_context in *. - eapply OnOne2_All_mix_left in X; tea. + eapply OnOne2_All_mix_left in X; tea. eapply OnOne2_All2... - simpl. intros x y [[[? ?] ?]]; unfold on_Trel; intuition pcuic; + simpl. intros x y [[[? ?] ?]]; unfold on_Trel; intuition pcuic; rewrite -?e; solve_all; repeat inv_on_free_vars_xpredT; eauto with fvs. eapply pred1_ctx_over_refl. eapply p5; eauto with fvs. eapply on_ctx_free_vars_inst_case_context_xpredT => //; eauto with fvs. solve_all. @@ -2072,13 +2072,13 @@ Section PredRed. Context (wfΣ : wf Σ). (** Parallel reduction is included in the reflexive transitive closure of 1-step reduction *) - Lemma pred1_red Γ Γ' : forall M N, pred1 Σ Γ Γ' M N -> + Lemma pred1_red Γ Γ' : forall M N, pred1 Σ Γ Γ' M N -> on_free_vars_ctx xpredT Γ -> on_free_vars xpredT M -> red Σ Γ M N. Proof using cf Σ wfΣ. - revert Γ Γ'. eapply (@pred1_ind_all_ctx Σ - (fun Γ Γ' M N => on_free_vars_ctx xpredT Γ -> on_free_vars xpredT M -> red Σ Γ M N) + revert Γ Γ'. eapply (@pred1_ind_all_ctx Σ + (fun Γ Γ' M N => on_free_vars_ctx xpredT Γ -> on_free_vars xpredT M -> red Σ Γ M N) (fun Γ Γ' => on_free_vars_ctx xpredT Γ -> All2_fold (on_decls (fun Γ Γ' M N => red Σ Γ M N)) Γ Γ')%type (fun Γ Γ' Δ Δ' => on_free_vars_ctx xpredT (Γ ,,, Δ) -> on_contexts_over (fun Γ Γ' M N => red Σ Γ M N) Γ Γ' Δ Δ')%type); intros; try reflexivity; repeat inv_on_free_vars_xpredT; try solve [pcuic]. @@ -2107,7 +2107,7 @@ Section PredRed. eapply All2_fold_All_left in a0. apply on_free_vars_ctx_All_fold in a0. eapply All_decls_on_free_vars_impl; tea. - cbn; intros ?? ont IH. + cbn; intros ?? ont IH. inv_on_free_vars_xpredT; eauto. eauto 6 with fvs. - (* Beta *) @@ -2191,7 +2191,7 @@ Section PredRed. reflexivity. * red. eapply forallb_All in p5. eapply All2_All_mix_left in X9; tea. - eapply (All2_impl X9); unfold on_Trel; intuition auto; + eapply (All2_impl X9); unfold on_Trel; intuition auto; repeat inv_on_free_vars_xpredT; eauto with fvs. * constructor. econstructor; eauto. @@ -2236,7 +2236,7 @@ Section PredRed. Lemma pred1_red_r_gen P Γ Γ' Δ Δ' : forall M N, on_free_vars (closedP #|Γ ,,, Δ| P) M -> on_ctx_free_vars (closedP #|Γ ,,, Δ| P) (Γ' ,,, Δ) -> - pred1 Σ (Γ ,,, Δ) (Γ' ,,, Δ') M N -> + pred1 Σ (Γ ,,, Δ) (Γ' ,,, Δ') M N -> #|Γ| = #|Γ'| -> pred1_ctx Σ (Γ' ,,, Δ) (Γ' ,,, Δ') -> pred1 Σ (Γ' ,,, Δ) (Γ' ,,, Δ') M N. @@ -2279,7 +2279,7 @@ Section PredRed. Lemma pred1_red_r_gen' P Γ Γ' Δ Δ' : forall M N, on_free_vars (shiftnP #|Γ ,,, Δ| P) M -> on_free_vars_ctx P (Γ' ,,, Δ) -> - pred1 Σ (Γ ,,, Δ) (Γ' ,,, Δ') M N -> + pred1 Σ (Γ ,,, Δ) (Γ' ,,, Δ') M N -> #|Γ| = #|Γ'| -> pred1_ctx Σ (Γ' ,,, Δ) (Γ' ,,, Δ') -> pred1 Σ (Γ' ,,, Δ) (Γ' ,,, Δ') M N. @@ -2291,7 +2291,7 @@ Section PredRed. apply X. pose proof (All2_fold_length predctx). len in H. red. split => //. split => //. - relativize #|Γ ,,, Δ|; [erewrite on_free_vars_ctx_on_ctx_free_vars|] => //; len. + relativize #|Γ ,,, Δ|; [erewrite on_free_vars_ctx_on_ctx_free_vars|] => //; len. intros x px. rewrite {1}/ids /=. split => //. split => //. eapply pred1_refl_gen => //. assert (#|Δ| = #|Δ'|). @@ -2321,7 +2321,7 @@ Section PredRed. now replace #|Δ'| with #|Δ| by lia. Qed. - Lemma pred1_pred1_r P Γ Γ' : forall M N, pred1 Σ Γ Γ' M N -> + Lemma pred1_pred1_r P Γ Γ' : forall M N, pred1 Σ Γ Γ' M N -> on_ctx_free_vars (closedP #|Γ| P) Γ' -> on_free_vars (closedP #|Γ| P) M -> pred1 Σ Γ' Γ' M N. @@ -2332,7 +2332,7 @@ Section PredRed. simpl. eapply pred1_ctx_refl. Qed. - Lemma pred1_pred1_r' P Γ Γ' : forall M N, pred1 Σ Γ Γ' M N -> + Lemma pred1_pred1_r' P Γ Γ' : forall M N, pred1 Σ Γ Γ' M N -> on_free_vars_ctx P Γ' -> on_free_vars (shiftnP #|Γ| P) M -> pred1 Σ Γ' Γ' M N. @@ -2344,7 +2344,7 @@ Section PredRed. Qed. Lemma pred1_red_r {P Γ Γ' M N} : - pred1 Σ Γ Γ' M N -> + pred1 Σ Γ Γ' M N -> on_free_vars_ctx P Γ' -> on_free_vars (shiftnP #|Γ| P) M -> red Σ Γ' M N. @@ -2356,7 +2356,7 @@ Section PredRed. eapply on_free_vars_ctx_impl; tea => //. eapply on_free_vars_impl; tea => //. Qed. - + End PredRed. #[global] Hint Resolve on_free_vars_ctx_any_xpredT : fvs. @@ -2584,7 +2584,7 @@ Qed. #[global] Hint Resolve ws_term_xpredT : fvs. (** A well-scoped context is a context obeying a free-variables predicate. - Note ths use of `on_free_vars_ctx` rather than `on_ctx_free_vars: + Note ths use of `on_free_vars_ctx` rather than `on_ctx_free_vars: we want a uniformly true predicate on the variables in the context. *) Definition ws_context P := { t : context | on_free_vars_ctx P t }. @@ -2617,12 +2617,12 @@ Proof. Qed. #[global] Hint Resolve ws_context_on_free_vars_xpredT : fvs. -Definition ws_red1 Σ P (Γ : ws_context P) (t u : ws_term (shiftnP #|Γ| P)) := +Definition ws_red1 Σ P (Γ : ws_context P) (t u : ws_term (shiftnP #|Γ| P)) := red1 Σ Γ t u. Definition ws_red Σ P (Γ : ws_context P) := clos_refl_trans (ws_red1 Σ P Γ). - -Definition ws_pair := + +Definition ws_pair := ∑ Γ : ws_context xpred0, ws_term (shiftnP #|Γ| xpred0). Definition ws_pair_context (t : ws_pair) : closed_context := t.π1. @@ -2630,30 +2630,30 @@ Definition ws_pair_term (t : ws_pair) : ws_term (shiftnP #|ws_pair_context t| xp Coercion ws_pair_context : ws_pair >-> closed_context. Coercion ws_pair_term : ws_pair >-> ws_term. -Definition ws_pred1_curry Σ P (Γ Γ' : ws_context P) (t u : ws_term (shiftnP #|Γ| P)) := +Definition ws_pred1_curry Σ P (Γ Γ' : ws_context P) (t u : ws_term (shiftnP #|Γ| P)) := pred1 Σ Γ Γ' t u. Definition ws_pred1 Σ (t u : ws_pair) := pred1 Σ t.π1 u.π1 t.π2 u.π2. - + Definition ws_pred_curry Σ P (Γ Γ' : ws_context P) := clos_refl_trans (ws_pred1_curry Σ P Γ Γ'). Definition ws_pred Σ := clos_refl_trans (ws_pred1 Σ). -Lemma ws_red1_pred1_curry {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {P} {Γ : ws_context P} +Lemma ws_red1_pred1_curry {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {P} {Γ : ws_context P} {t u : ws_term (shiftnP #|Γ| P)} : ws_red1 Σ P Γ t u -> ws_pred1_curry Σ P Γ Γ t u. Proof. eapply red1_pred1; eauto with fvs. Qed. -Lemma ws_red1_pred1 {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {Γ : closed_context} +Lemma ws_red1_pred1 {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {Γ : closed_context} {t u : ws_term (shiftnP #|Γ| xpred0)} : ws_red1 Σ _ Γ t u -> ws_pred1 Σ (Γ; t) (Γ; u). Proof. eapply red1_pred1; eauto with fvs. Qed. -Lemma red_pred' {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {P} {Γ : ws_context P} +Lemma red_pred' {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {P} {Γ : ws_context P} {t u : ws_term (shiftnP #|Γ| P)} : ws_red Σ P Γ t u -> ws_pred_curry Σ P Γ Γ t u. Proof. @@ -2661,7 +2661,7 @@ Proof. eapply red1_pred1; eauto with fvs. Qed. -Lemma ws_pred_ws_pred_curry {Σ} {Γ : closed_context} {t : ws_term (shiftnP #|Γ| xpred0)} {u : ws_term (shiftnP #|Γ| xpred0)} : +Lemma ws_pred_ws_pred_curry {Σ} {Γ : closed_context} {t : ws_term (shiftnP #|Γ| xpred0)} {u : ws_term (shiftnP #|Γ| xpred0)} : ws_pred_curry Σ xpred0 Γ Γ t u -> ws_pred Σ (Γ; t) (Γ; u). Proof. induction 1. constructor 1. apply r. @@ -2676,7 +2676,7 @@ Proof. intros r. now eapply ws_pred_ws_pred_curry, red_pred'. Qed. -Lemma ws_pred1_red {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {P} {Γ Γ' : ws_context P} +Lemma ws_pred1_red {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {P} {Γ Γ' : ws_context P} {t : ws_term (shiftnP #|Γ| P)} {u : ws_term (shiftnP #|Γ'| P)} : pred1 Σ Γ Γ' t u -> red Σ Γ t u. Proof. @@ -2685,7 +2685,7 @@ Qed. #[program] Definition rho_ws_pair {cf:checker_flags} (Σ : global_env) {wfΣ : wf Σ} (p : ws_pair) : ws_pair := - (rho_ctx Σ p; rho Σ (rho_ctx Σ p) p). + (rho_ctx Σ p; rho Σ (rho_ctx Σ p) p). Next Obligation. destruct p as [Γ t]. cbn. pose proof (@triangle cf Σ wfΣ Γ Γ (tRel 0) (tRel 0)). @@ -2715,9 +2715,9 @@ Qed. #[global] Hint Resolve pred1_on_free_vars_ctx : fvs. -Lemma pred1_on_free_vars_on_free_vars_ctx {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} +Lemma pred1_on_free_vars_on_free_vars_ctx {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {P} {Γ Γ' : context} {t u : term} : - pred1 Σ Γ Γ' t u -> + pred1 Σ Γ Γ' t u -> on_free_vars_ctx P Γ -> on_free_vars (shiftnP #|Γ| P) t -> on_free_vars (shiftnP #|Γ| P) u. Proof. @@ -2778,7 +2778,7 @@ Section RedConfluence. Inductive clos_refl_trans_ctx_decl (R : relation context_decl) (x : context_decl) : context_decl -> Type := rt_ctx_decl_step : forall y, R x y -> clos_refl_trans_ctx_decl R x y - | rt_ctx_decl_refl y : eq_binder_annot x.(decl_name) y.(decl_name) -> + | rt_ctx_decl_refl y : eq_binder_annot x.(decl_name) y.(decl_name) -> decl_body x = decl_body y -> decl_type x = decl_type y -> clos_refl_trans_ctx_decl R x y | rt_ctx_decl_trans : forall y z, clos_refl_trans_ctx_decl R x y -> clos_refl_trans_ctx_decl R y z -> clos_refl_trans_ctx_decl R x z. @@ -2811,7 +2811,7 @@ Section RedConfluence. Lemma red1_ctx_pred1_ctx {Γ Γ' : closed_context} : ws_red1_ctx Γ Γ' -> ws_pred1_ctx Γ Γ'. Proof using wfΣ. rewrite /ws_red1_ctx /ws_pred1_ctx /lift_ws /=. - move: Γ Γ' => [Γ onΓ] [Γ' onΓ'] /= a. + move: Γ Γ' => [Γ onΓ] [Γ' onΓ'] /= a. elim: a onΓ onΓ'. - move=> Γ0 na na' t t' /= [-> r]. rewrite !on_free_vars_ctx_snoc /= /on_free_vars_decl /test_decl /= => /andP[] onΓ0 ont @@ -2826,7 +2826,7 @@ Section RedConfluence. constructor; destruct H as [[red ->]|[red ->]]; (eapply pred1_refl || eapply red1_pred1); eauto with fvs. - move=> Γ0 Γ'0 d onΓ IH; rewrite !on_free_vars_ctx_snoc /= => /andP[] onΓ0 _ /andP[] onΓ'0 _. - constructor; auto. + constructor; auto. eapply All_decls_refl; tc. intros x; apply pred1_refl_gen; eauto. Qed. @@ -2859,7 +2859,7 @@ Section RedConfluence. Qed. Hint Constructors clos_refl_trans_ctx : pcuic. - Hint Resolve alpha_eq_reflexive : pcuic. + Hint Resolve alpha_eq_reflexive : pcuic. Set Firstorder Solver eauto with pcuic core typeclass_instances. Lemma clos_rt_OnOne2_local_env_ctx_incl R : @@ -2869,7 +2869,7 @@ Section RedConfluence. intros x y H. induction H; firstorder; try solve[econstructor; eauto]. Qed. - + Lemma red_ctx_clos_rt_red1_ctx : inclusion (red_ctx Σ) (clos_refl_trans_ctx (red1_ctx Σ)). Proof using wfΣ. intros x y H. @@ -2895,7 +2895,7 @@ Section RedConfluence. Inductive clos_refl_trans_ctx_t (R : relation ws_pair) (x : ws_pair) : ws_pair -> Type := | rt_ctx_t_step : forall y, R x y -> clos_refl_trans_ctx_t R x y | rt_ctx_t_refl (y : ws_pair) : eq_context_upto_names x.π1 y.π1 -> x.π2 = y.π2 :> term -> clos_refl_trans_ctx_t R x y - | rt_ctx_t_trans : forall y z, clos_refl_trans_ctx_t R x y -> clos_refl_trans_ctx_t R y z -> + | rt_ctx_t_trans : forall y z, clos_refl_trans_ctx_t R x y -> clos_refl_trans_ctx_t R y z -> clos_refl_trans_ctx_t R x z. Global Instance clos_refl_trans_ctx_t_refl R : @@ -2931,7 +2931,7 @@ Section RedConfluence. Qed. Lemma clos_refl_trans_ctx_t_prod_l (R : relation context) (S : relation ws_pair) : - (forall x y, on_free_vars_ctx xpred0 x -> clos_refl_trans_ctx R x y -> + (forall x y, on_free_vars_ctx xpred0 x -> clos_refl_trans_ctx R x y -> on_free_vars_ctx xpred0 y) -> (forall x y, clos_refl_trans_ctx R x y -> #|x| = #|y|) -> (forall (x y : closed_context) (b : ws_term (shiftnP #|x| xpred0)) (b' : ws_term (shiftnP #|y| xpred0)), @@ -2968,7 +2968,7 @@ Section RedConfluence. now destruct (uip ht ht'). Qed. - Lemma red1_ctx_on_free_vars P Γ Δ : + Lemma red1_ctx_on_free_vars P Γ Δ : on_free_vars_ctx P Γ -> red1_ctx Σ Γ Δ -> on_free_vars_ctx P Δ. @@ -2977,13 +2977,13 @@ Section RedConfluence. induction 1 in onp |- *. - depelim p. subst. move: onp; rewrite !on_free_vars_ctx_snoc => /andP[] onΓ /=; rewrite /on_free_vars_decl /test_decl /=. - rewrite onΓ => ont /=. + rewrite onΓ => ont /=. intros; eapply red1_on_free_vars; eauto with fvs. now rewrite on_free_vars_ctx_on_ctx_free_vars. - depelim p. subst. move: onp; rewrite !on_free_vars_ctx_snoc => /andP[] onΓ /=; rewrite /on_free_vars_decl /test_decl /=. rewrite onΓ => /andP[] onb ont /=. - apply/andP. + apply/andP. destruct s as [[red <-]|[red <-]]; split => //. all:eapply red1_on_free_vars; tea. all:rewrite on_free_vars_ctx_on_ctx_free_vars //. @@ -2992,7 +2992,7 @@ Section RedConfluence. now rewrite -(OnOne2_local_env_length X). Qed. - Lemma eq_context_upto_names_on_free_vars P Γ Δ : + Lemma eq_context_upto_names_on_free_vars P Γ Δ : on_free_vars_ctx P Γ -> eq_context_upto_names Γ Δ -> on_free_vars_ctx P Δ. @@ -3008,8 +3008,8 @@ Section RedConfluence. destruct p as [onfvs cd]. depelim cd; subst; auto. Qed. - - Lemma clos_refl_trans_ctx_on_free_vars P Γ Δ : + + Lemma clos_refl_trans_ctx_on_free_vars P Γ Δ : on_free_vars_ctx P Γ -> clos_refl_trans_ctx (red1_ctx Σ) Γ Δ -> on_free_vars_ctx P Δ. @@ -3021,7 +3021,7 @@ Section RedConfluence. - eauto. Qed. - Lemma clos_refl_trans_ctx_length Γ Δ : + Lemma clos_refl_trans_ctx_length Γ Δ : clos_refl_trans_ctx (red1_ctx Σ) Γ Δ -> #|Γ| = #|Δ|. Proof using Type. induction 1. @@ -3092,7 +3092,7 @@ Section RedConfluence. - left. subst. simpl in eq. subst. eapply pred1_refl_gen. now apply red1_ctx_pred1_ctx. - right; split; auto. Qed. - + Lemma clos_refl_trans_prod_l_sigma {A B} {P : A -> B -> Prop} (R : relation A) (S : relation (∑ x : A, { y : B | P x y })) : (forall x b hb hb', clos_refl_trans S (x; exist b hb) (x; exist b hb')) -> (forall x y b, P x b -> clos_refl_trans R x y -> P y b) -> @@ -3116,7 +3116,7 @@ Section RedConfluence. intros. induction X0; try solve [econstructor; eauto]. Qed. - Lemma red_ws_red (Γ : closed_context) (x y : ws_term (shiftnP #|Γ| xpred0)) : + Lemma red_ws_red (Γ : closed_context) (x y : ws_term (shiftnP #|Γ| xpred0)) : red Σ Γ x y -> ws_red Σ xpred0 Γ x y. Proof using wfΣ. destruct Γ as [Γ hΓ]. @@ -3133,9 +3133,9 @@ Section RedConfluence. eapply (IHX1 hx H). eauto. Qed. - + Lemma clos_refl_trans_red1_ctx_eq_length (Γ Δ : closed_context) : - clos_refl_trans (fun x y : closed_context => + clos_refl_trans (fun x y : closed_context => relation_disjunction (red1_ctx Σ) eq_context_upto_names x y) Γ Δ -> #|Γ| = #|Δ|. Proof using Type. induction 1. @@ -3160,7 +3160,7 @@ Section RedConfluence. eapply clos_refl_trans_prod_r; tea. intros. split; eauto. exact X. now eapply red_ws_red. + eapply clos_rt_disjunction_right. - eapply (clos_refl_trans_prod_l_sigma (P:=fun (Γ : closed_context) t => on_free_vars (shiftnP #|Γ| xpred0) t) + eapply (clos_refl_trans_prod_l_sigma (P:=fun (Γ : closed_context) t => on_free_vars (shiftnP #|Γ| xpred0) t) (relation_disjunction (red1_ctx Σ) eq_context_upto_names)); tea. { intros. destruct (uip hb hb'). constructor 2. } { intros. eapply clos_refl_trans_red1_ctx_eq_length in X. now rewrite -X. } @@ -3180,7 +3180,7 @@ Section RedConfluence. - constructor. right. right. destruct x, y; cbn in *; auto. Qed. - Lemma pred1_upto_names_gen {P Γ Γ' Δ Δ' t u} : + Lemma pred1_upto_names_gen {P Γ Γ' Δ Δ' t u} : on_free_vars_ctx P Γ -> on_free_vars (shiftnP #|Γ| P) t -> pred1 Σ Γ Δ t u -> @@ -3215,7 +3215,7 @@ Section RedConfluence. rewrite hnth'' //. Qed. - Lemma pred1_ctx_upto_names {P Γ Γ' Δ} : + Lemma pred1_ctx_upto_names {P Γ Γ' Δ} : on_free_vars_ctx P Γ -> pred1_ctx Σ Γ Δ -> eq_context_upto_names Γ Γ' -> @@ -3225,9 +3225,9 @@ Section RedConfluence. induction eqctx in Δ, pr, onfvs |- *; depelim pr. - exists []; split; auto; pcuic. - move: onfvs; rewrite on_free_vars_ctx_snoc /on_free_vars_decl /test_decl /= => /andP[] /= onΓ ont. - depelim a. + depelim a. * depelim r. cbn in ont. subst. - destruct (IHeqctx _ onΓ pr) as [Δ' [pred' eq']]. + destruct (IHeqctx _ onΓ pr) as [Δ' [pred' eq']]. exists (vass na' t' :: Δ'). split. constructor. apply pred'. constructor. eapply pred1_upto_names_gen; tea. eauto with fvs. @@ -3242,9 +3242,9 @@ Section RedConfluence. constructor => //. constructor => //. Qed. - Lemma pred1_upto_names {P Γ Γ' Δ t u} : + Lemma pred1_upto_names {P Γ Γ' Δ t u} : on_free_vars_ctx P Γ -> - on_free_vars (shiftnP #|Γ| P) t -> + on_free_vars (shiftnP #|Γ| P) t -> pred1 Σ Γ Δ t u -> eq_context_upto_names Γ Γ' -> ∑ Δ', pred1 Σ Γ' Δ' t u × eq_context_upto_names Δ Δ'. @@ -3304,11 +3304,11 @@ Section RedConfluence. clos_refl_trans (red1 Σ Γ) x y -> clos_refl_trans red1_rel (Γ; x) (Γ; y). Proof using wfΣ. destruct x as [x hx], y as [y hy]; cbn. - induction 1. + induction 1. - constructor. red. left. pcuicfo. - destruct (uip hx hy). constructor 2. - - econstructor 3. + - econstructor 3. unshelve eapply IHX1. cbn. eapply red_on_free_vars in X1; tea; eauto with fvs. cbn. eapply IHX2. @@ -3357,7 +3357,7 @@ Section RedConfluence. - econstructor 3; eauto. Qed. - Definition transport_on_free_vars {n m : nat} {t} (p : on_free_vars (shiftnP n xpred0) t) (eq : n = m) : + Definition transport_on_free_vars {n m : nat} {t} (p : on_free_vars (shiftnP n xpred0) t) (eq : n = m) : on_free_vars (shiftnP m xpred0) t. Proof. now destruct eq. Defined. @@ -3391,7 +3391,7 @@ Section RedConfluence. constructor 2. etransitivity; eauto. Qed. - + Hint Transparent context : typeclass_instances. Lemma red_ctx_red_context Γ Δ : red_ctx Σ Γ Δ <~> red_context Σ Γ Δ. @@ -3403,7 +3403,7 @@ Section RedConfluence. eapply All2_fold_impl; tea. intros ???? []; constructor; auto. Qed. - + Lemma red_context_trans {Γ Δ Δ' : context} : on_ctx_free_vars (closedP #|Γ| xpredT) Γ -> red_ctx Σ Γ Δ -> red_ctx Σ Δ Δ' -> red_ctx Σ Γ Δ'. @@ -3412,7 +3412,7 @@ Section RedConfluence. move/red_ctx_red_context => h /red_ctx_red_context h'. apply red_ctx_red_context. eapply red_context_trans; tea. Qed. - + Global Instance ws_red_ctx_refl : Reflexive ws_red_ctx. Proof using Type. intros Γ. red. red. reflexivity. @@ -3476,7 +3476,7 @@ Section RedConfluence. cbn in *. now rewrite (uip ht ht') (uip hu hu'). Qed. - + Lemma clos_rt_red1_rel_ws_red1 x y : clos_refl_trans red1_rel x y -> ∑ redctx : ws_red_ctx x.π1 y.π1, @@ -3496,7 +3496,7 @@ Section RedConfluence. red in r. destruct r. * destruct p. subst. exists x. red. transitivity u; auto. - * destruct p. subst. + * destruct p. subst. apply red1_ctx_pred1_ctx in r. apply pred1_ctx_red_ctx in r. exists (transitivity r x). @@ -3504,7 +3504,7 @@ Section RedConfluence. unshelve eapply ws_red_red_ctx in w. shelve. exact r. eapply ws_red_irrel. exact w. Qed. - + Lemma clos_rt_red1_rel_red1 x y : clos_refl_trans red1_rel x y -> red_ctx Σ x.π1 y.π1 * clos_refl_trans (red1 Σ x.π1) x.π2 y.π2. @@ -3572,7 +3572,7 @@ Section RedConfluence. intros HΓ H. move: H. apply clos_rt_monotone => x y. now apply red1_eq_context_upto_names. Qed. - + Definition red_ctx_alpha : relation context := All2_fold (fun Γ _ => All_decls_alpha (red Σ Γ)). @@ -3621,7 +3621,7 @@ Section RedConfluence. intros x; apply All2_fold_refl; tc. Qed. - Lemma red_ctx_red_ctx_alpha_trans {Γ Δ Δ'} : + Lemma red_ctx_red_ctx_alpha_trans {Γ Δ Δ'} : ws_red_ctx Γ Δ -> red_ctx_alpha Δ Δ' -> red_ctx_alpha Γ Δ'. Proof using wfΣ. destruct Γ as [Γ onΓ], Δ as [Δ onΔ]; cbn. rewrite /ws_red_ctx /lift_ws /=. @@ -3646,7 +3646,7 @@ Section RedConfluence. rewrite on_free_vars_ctx_on_ctx_free_vars //. Qed. - Lemma ws_red_refl_irrel P (Γ : ws_context P) (x y : ws_term (shiftnP #|Γ| P)) : + Lemma ws_red_refl_irrel P (Γ : ws_context P) (x y : ws_term (shiftnP #|Γ| P)) : x = y :> term -> ws_red Σ P Γ x y. Proof using Type. @@ -3689,7 +3689,7 @@ Section RedConfluence. move/clos_rt_red1_alpha_out => [redctx redt]. split => //. now eapply ws_red_red in redt. Qed. - + Inductive clos_refl_trans_ctx_1n (R : relation context) (x : context) : context -> Type := | rt1n_ctx_eq : clos_refl_trans_ctx_1n R x x | rt1n_ctx_trans : forall y z, eq_context_upto_names x y + R x y -> clos_refl_trans_ctx_1n R y z -> clos_refl_trans_ctx_1n R x z. @@ -3711,7 +3711,7 @@ Section RedConfluence. induction 1. constructor 2. reflexivity. destruct s. econstructor 3. constructor 2; eauto. eauto. econstructor 3. constructor 1; eauto. eauto. - Qed. + Qed. Lemma clos_rt_red1_red1_rel_alpha (Γ : closed_context) (x y : ws_term (shiftnP #|Γ| xpred0)) : clos_refl_trans (red1 Σ Γ) x y -> clos_refl_trans red1_rel_alpha (Γ; x) (Γ; y). @@ -3726,7 +3726,7 @@ Section RedConfluence. - cbn in *. assert (hy' : on_free_vars (shiftnP #|Γ| xpred0) y). { eapply red_on_free_vars; tea; eauto with fvs. } - specialize (IHX1 hx hy'). + specialize (IHX1 hx hy'). econstructor 3; eauto. Qed. @@ -3739,7 +3739,7 @@ Section RedConfluence. destruct X as [[Δ nf] [redl redr]]. eapply clos_rt_red1_alpha_out' in redl. eapply clos_rt_red1_alpha_out' in redr. simpl in *. - intuition auto. red. + intuition auto. red. assert (on_free_vars (shiftnP #|Γ| xpred0) nf) by eauto with fvs. eexists (exist (proj1_sig nf) H : ws_term (shiftnP #|Γ| xpred0)). now split; apply red_ws_red; cbn. @@ -3806,7 +3806,7 @@ Section ConfluenceFacts. Context {cf : checker_flags}. Context {Σ : global_env_ext} {wfΣ : wf Σ}. - Lemma lift_to_ws_red {Γ : closed_context} {x : term} {p : on_free_vars (shiftnP #|Γ| xpred0) x} {y} : + Lemma lift_to_ws_red {Γ : closed_context} {x : term} {p : on_free_vars (shiftnP #|Γ| xpred0) x} {y} : red Σ Γ x y -> ∑ x' y' : open_term Γ, x = x' :> term × y = y' :> term × ws_red Σ xpred0 Γ x' y'. @@ -3827,7 +3827,7 @@ Section ConfluenceFacts. - etransitivity; tea. Qed. - Lemma ws_pred_pred {Γ : closed_context} {t : open_term Γ} {u} : + Lemma ws_pred_pred {Γ : closed_context} {t : open_term Γ} {u} : ws_pred_curry Σ xpred0 Γ Γ t u -> clos_refl_trans (pred1 Σ Γ Γ) t u. Proof using Type. @@ -3838,7 +3838,7 @@ Section ConfluenceFacts. - econstructor 3; tea. Qed. - Lemma lift_to_pred {Γ : closed_context} {x : term} {p : on_free_vars (shiftnP #|Γ| xpred0) x} {y} : + Lemma lift_to_pred {Γ : closed_context} {x : term} {p : on_free_vars (shiftnP #|Γ| xpred0) x} {y} : red Σ Γ x y -> ∑ x' y' : open_term Γ, x = x' :> term × y = y' :> term × clos_refl_trans (pred1 Σ Γ Γ) x' y'. @@ -3872,12 +3872,12 @@ Section ConfluenceFacts. Qed. Lemma red_mkApps_tInd {Γ : closed_context} {ind u} {args : list term} {c} : - forallb (on_free_vars (shiftnP #|Γ| xpred0)) args -> + forallb (on_free_vars (shiftnP #|Γ| xpred0)) args -> red Σ Γ (mkApps (tInd ind u) args) c -> ∑ args' : list term, (c = mkApps (tInd ind u) args') * (All2 (red Σ Γ) args args'). Proof using wfΣ. - move=> hargs /lift_to_pred. + move=> hargs /lift_to_pred. rewrite on_free_vars_mkApps /= hargs. move/(_ eq_refl) => [] [x' onx'] [] [y' ony'] [] eqx' [] /= -> wsr. cbn in *. subst x'. @@ -3894,14 +3894,14 @@ Section ConfluenceFacts. Qed. Lemma red_mkApps_tRel {Γ : closed_context} {k b} {args : list term} {c} : - forallb (on_free_vars (shiftnP #|Γ| xpred0)) args -> + forallb (on_free_vars (shiftnP #|Γ| xpred0)) args -> nth_error Γ k = Some b -> decl_body b = None -> red Σ Γ (mkApps (tRel k) args) c -> ∑ args' : list term, (c = mkApps (tRel k) args') * (All2 (red Σ Γ) args args'). Proof using wfΣ. move => hargs Hnth Hb /lift_to_pred. - rewrite on_free_vars_mkApps /= hargs /shiftnP orb_false_r + rewrite on_free_vars_mkApps /= hargs /shiftnP orb_false_r (proj2 (Nat.ltb_lt _ _) (nth_error_Some_length Hnth)) /=. move/(_ eq_refl) => [] [x' onx'] [] [y' ony'] [] eqx' [] /= -> wsr. cbn in *. subst x'. @@ -3919,7 +3919,7 @@ Section ConfluenceFacts. Lemma red_mkApps_tConst_axiom {Γ : closed_context} {cst u} {args : list term} {cb c} : declared_constant Σ cst cb -> cst_body cb = None -> - forallb (on_free_vars (shiftnP #|Γ| xpred0)) args -> + forallb (on_free_vars (shiftnP #|Γ| xpred0)) args -> red Σ Γ (mkApps (tConst cst u) args) c -> ∑ args' : list term, (c = mkApps (tConst cst u) args') * (All2 (red Σ Γ) args args'). @@ -3950,7 +3950,7 @@ Section ConfluenceFacts. Qed. Notation byfvs := (_ ltac:(eauto with fvs)) (only parsing). - + Lemma red_ws_red_left {Γ : closed_context} {x : ws_term (shiftnP #|Γ| xpred0)} {y} : red Σ Γ x y -> ∑ prf, ws_red Σ xpred0 Γ x (exist y prf). Proof using wfΣ. @@ -3965,7 +3965,7 @@ Section ConfluenceFacts. ∑ v', red Σ Γ u v' * red Σ Γ v v'. Proof using wfΣ. move/red_ws_red_left => [onu redu]. - move/red_ws_red_left => [onv redv]. + move/red_ws_red_left => [onv redv]. destruct (ws_red_confluence redu redv) as [nf [redl redr]]. now exists nf; split; [eapply ws_red_red in redl | eapply ws_red_red in redr]. Qed. diff --git a/pcuic/theories/PCUICContextConversion.v b/pcuic/theories/PCUICContextConversion.v index 509afdbf4..ee2afdb39 100644 --- a/pcuic/theories/PCUICContextConversion.v +++ b/pcuic/theories/PCUICContextConversion.v @@ -36,7 +36,7 @@ Definition closed_red_ctx Σ Γ Γ' := Notation "Σ ⊢ Γ ⇝ Δ" := (closed_red_ctx Σ Γ Δ) (at level 50, Γ, Δ at next level, format "Σ ⊢ Γ ⇝ Δ") : pcuic. -Lemma closed_red_ctx_red_ctx {Σ Γ Γ'} : +Lemma closed_red_ctx_red_ctx {Σ Γ Γ'} : Σ ⊢ Γ ⇝ Γ' -> red_ctx Σ Γ Γ'. Proof. intros a; eapply All2_fold_impl; tea. @@ -77,20 +77,20 @@ Section ContextReduction. Lemma All2_fold_over_red_refl {Γ Δ} : All2_fold (on_decls (fun (Δ _ : context) (t u : term) => red Σ (Γ ,,, Δ) t u)) Δ Δ. - Proof using Type. induction Δ as [|[na [b|] ty]]; econstructor; try red; auto. + Proof using Type. induction Δ as [|[na [b|] ty]]; econstructor; try red; auto. constructor; reflexivity. constructor; reflexivity. Qed. Lemma All2_fold_red_refl {Δ} : All2_fold (on_decls (fun (Δ _ : context) (t u : term) => red Σ Δ t u)) Δ Δ. - Proof using Type. + Proof using Type. induction Δ as [|[na [b|] ty]]; econstructor; try red; auto; constructor; reflexivity. Qed. Derive Signature for assumption_context. - Lemma red1_red_ctxP_app {Γ Γ' Δ} : + Lemma red1_red_ctxP_app {Γ Γ' Δ} : red1_red_ctxP Γ Γ' -> red1_red_ctxP (Γ ,,, Δ) (Γ' ,,, Δ). Proof using Type. @@ -107,7 +107,7 @@ Section ContextReduction. Ltac t := split; [eapply red1_red; try econstructor; eauto|try constructor]; eauto with pcuic. Ltac u := intuition eauto with pcuic. - Lemma red_ctx_app Γ Γ' Δ : + Lemma red_ctx_app Γ Γ' Δ : red_ctx Σ Γ Γ' -> red_ctx Σ (Γ ,,, Δ) (Γ' ,,, Δ). Proof using Type. intros h; eapply All2_fold_app => //. @@ -135,7 +135,7 @@ Section ContextReduction. ∑ t, red Σ Γ' T t * red Σ Γ' U t. Proof using wfΣ. intros r onT onΓ H. revert onT onΓ Γ' H. - simpl in *. induction r using red1_ind_all; intros; auto with pcuic; + simpl in *. induction r using red1_ind_all; intros; auto with pcuic; repeat inv_on_free_vars_xpredT. all:try solve [eexists; t]. all:try specialize (IHr ltac:(tea) ltac:(eauto with fvs)). @@ -211,7 +211,7 @@ Section ContextReduction. eapply red_case_p; tea. - exists (tCase ind p x brs). u; now apply red_case_c. - solve_all. eapply OnOne2_All_mix_left in X; tea. - eapply (OnOne2_exist _ + eapply (OnOne2_exist _ (fun br br' => on_Trel_eq (red Σ (Γ' ,,, inst_case_branch_context p br)) bbody bcontext br br')) in X. destruct X as [brs'' [? ?]]. eexists. split; eapply red_case_one_brs; eauto; @@ -347,7 +347,7 @@ Section ContextReduction. Proof using wfΣ. intros. eapply red_red_ctx', red_red_ctx_aux'; eauto. Qed. - + End ContextReduction. Definition inj_closed (Γ : context) (o : on_free_vars_ctx xpred0 Γ) : closed_context := @@ -361,7 +361,7 @@ Arguments inj_open {Γ} & t o. #[global] Hint Resolve red_ctx_on_free_vars : fvs. Lemma red_ctx_on_free_vars_term {Σ P Γ Γ' t} : - red_ctx Σ Γ Γ' -> + red_ctx Σ Γ Γ' -> on_free_vars (shiftnP #|Γ| P) t -> on_free_vars (shiftnP #|Γ'| P) t. Proof. @@ -377,7 +377,7 @@ Proof. now transitivity y. Qed. -Definition compare_context {cf} pb Σ := +Definition compare_context {cf} pb Σ := eq_context_upto Σ (eq_universe Σ) (compare_universe pb Σ). Section ContextConversion. @@ -443,7 +443,7 @@ Section ContextConversion. Lemma red_compare_term_l {pb Γ} {u v u' : term} : compare_term pb Σ Σ u u' -> - red Σ Γ u v -> + red Σ Γ u v -> ∑ v' : term, red Σ Γ u' v' × compare_term pb Σ Σ v v'. Proof using Type. destruct pb; cbn; @@ -452,7 +452,7 @@ Section ContextConversion. Lemma red_compare_term_r {pb Γ} {u v u' : term} : compare_term pb Σ Σ u u' -> - red Σ Γ u' v -> + red Σ Γ u' v -> ∑ v' : term, red Σ Γ u v' × compare_term pb Σ Σ v' v. Proof using Type. destruct pb; cbn; @@ -462,23 +462,23 @@ Section ContextConversion. Lemma closed_red_compare_term_l {pb Γ} {u v u' : term} : is_open_term Γ u' -> compare_term pb Σ Σ u u' -> - Σ ;;; Γ ⊢ u ⇝ v -> + Σ ;;; Γ ⊢ u ⇝ v -> ∑ v' : term, Σ ;;; Γ ⊢ u' ⇝ v' × compare_term pb Σ Σ v v'. Proof using Type. intros isop comp [clΓ clu red]. destruct (red_compare_term_l comp red) as [nf [r eq]]. - exists nf; repeat (split; eauto with fvs). + exists nf; repeat (split; eauto with fvs). Qed. Lemma closed_red_compare_term_r {pb Γ} {u v u' : term} : is_open_term Γ u -> compare_term pb Σ Σ u u' -> - Σ ;;; Γ ⊢ u' ⇝ v -> + Σ ;;; Γ ⊢ u' ⇝ v -> ∑ v' : term, Σ ;;; Γ ⊢ u ⇝ v' × compare_term pb Σ Σ v' v. Proof using Type. intros isop comp [clΓ clu red]. destruct (red_compare_term_r comp red) as [nf [r eq]]. - exists nf; repeat (split; eauto with fvs). + exists nf; repeat (split; eauto with fvs). Qed. Lemma closed_red_red_ctx {Γ Γ'} {T U} : @@ -490,17 +490,17 @@ Section ContextConversion. assert (is_open_term Γ U) by eauto with fvs. eapply (red_red_ctx Σ wfΣ (Γ := exist Γ clΓ) (T := exist T clT)) in r as [t [r r']]. 2:exact rctx. - exists t. split. split; auto. eauto with fvs. + exists t. split. split; auto. eauto with fvs. rewrite -(length_of rctx); eauto with fvs. split; eauto with fvs. rewrite -(length_of rctx); eauto with fvs. Qed. Lemma ws_cumul_pb_red {pb} {Γ t u} : - Σ ;;; Γ ⊢ t ≤[pb] u <~> + Σ ;;; Γ ⊢ t ≤[pb] u <~> ∑ v v', [× Σ ;;; Γ ⊢ t ⇝ v, Σ ;;; Γ ⊢ u ⇝ v' & compare_term pb Σ (global_ext_constraints Σ) v v']. - Proof using wfΣ. + Proof using wfΣ. split. - move/ws_cumul_pb_alt; intros (v & v' & [clΓ clt clu red red' leq]). exists v, v'; repeat split; eauto with fvs. @@ -517,7 +517,7 @@ Section ContextConversion. destruct (red_confluence (Γ := exist Γ clΓ) (t := exist t clT) r r') as [v' [redl redr]]. cbn in *. exists v'; repeat split; eauto with fvs. Qed. - + Lemma ws_cumul_pb_red_ctx {pb} {Γ Γ'} {T U} : Σ ⊢ Γ ⇝ Γ' -> Σ ;;; Γ ⊢ T ≤[pb] U -> @@ -546,8 +546,8 @@ Section ContextConversion. Qed. Lemma red_red_ctx_inv' {Γ Δ : context} {t u} : - Σ ⊢ Δ ⇝ Γ -> - Σ ;;; Γ ⊢ t ⇝ u -> + Σ ⊢ Δ ⇝ Γ -> + Σ ;;; Γ ⊢ t ⇝ u -> Σ ;;; Δ ⊢ t ⇝ u. Proof using wfΣ. intros rc [onΓ ont r]. @@ -573,7 +573,7 @@ Section ContextConversion. apply ws_cumul_pb_red. now exists v, v'. Qed. - + Lemma red_eq_context_upto_l {R Re} {Γ Δ} {u} {v} `{RelationClasses.Reflexive _ R} `{RelationClasses.Transitive _ R} `{SubstUnivPreserving R} `{RelationClasses.Reflexive _ Re} `{RelationClasses.Transitive _ Re} `{SubstUnivPreserving Re} @@ -685,7 +685,7 @@ Section ContextConversion. transitivity nf. now symmetry. now transitivity nf'. Qed. - + Lemma conv_leq_context_upto {Γ Δ T U} : eq_context_upto Σ (eq_universe Σ) (leq_universe Σ) Γ Δ -> Σ ;;; Δ |- T = U -> @@ -702,10 +702,10 @@ Section ContextConversion. now symmetry. now transitivity nf'. Qed. - (* Conversion is untyped so this currently holds as context ws_cumul_pb - just allows cumulativity on types, which do not participate in reduction. - However the useful lemma is the one above that shows we can lift a - conversion from a large context to a smaller one (contravariance). + (* Conversion is untyped so this currently holds as context ws_cumul_pb + just allows cumulativity on types, which do not participate in reduction. + However the useful lemma is the one above that shows we can lift a + conversion from a large context to a smaller one (contravariance). *) Local Remark conv_eq_context_upto_leq_inv {Γ Δ T U} : eq_context_upto Σ (eq_universe Σ) (leq_universe Σ) Γ Δ -> @@ -761,7 +761,7 @@ Section ContextConversion. transitivity nf'; auto. now apply eq_term_leq_term. Qed. - + Local Remark ws_cumul_pb_compare_context_inv {pb pb' Γ Δ T U} : compare_context pb Σ Γ Δ -> is_closed_context Δ -> @@ -780,7 +780,7 @@ Section ContextConversion. - transitivity nf'; auto. - apply eq_term_leq_term. now symmetry. - transitivity nf' => //. - now apply eq_term_leq_term. + now apply eq_term_leq_term. Qed. (* Local Remark cumul_leq_context_upto_inv {Γ Δ T U} : @@ -805,7 +805,7 @@ Section ContextConversion. `{RelationClasses.subrelation _ Re Re'} `{RelationClasses.subrelation _ Rle Rle'} `{RelationClasses.subrelation _ Re' Rle'} : - eq_context_upto Σ Re Rle Γ Δ -> + eq_context_upto Σ Re Rle Γ Δ -> eq_context_upto Σ Re' Rle' Γ Δ. Proof using Type. induction 1; constructor; auto. @@ -817,7 +817,7 @@ Section ContextConversion. transitivity Re'; auto. Qed. - Lemma eq_leq_context_upto Γ Δ : + Lemma eq_leq_context_upto Γ Δ : eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Γ Δ -> eq_context_upto Σ (eq_universe Σ) (leq_universe Σ) Γ Δ. Proof using Type. apply eq_context_upto_impl. Qed. @@ -871,7 +871,7 @@ Section ContextConversion. exists v, v'. split. pcuic. auto. Qed. - + Lemma cumul_alt_red_ctx {Γ : closed_context} {Γ'} {T U : open_term Γ} : Σ ;;; Γ |- T <= U -> @red_ctx Σ Γ Γ' -> @@ -909,21 +909,21 @@ Section ContextConversion. Proof using wfΣ. intros Hctx H. apply ws_cumul_pb_red in H as [v [v' [redl redr leq]]]. - epose proof (red_red_ctx_inv' Hctx redl). - epose proof (red_red_ctx_inv' Hctx redr). + epose proof (red_red_ctx_inv' Hctx redl). + epose proof (red_red_ctx_inv' Hctx redr). apply ws_cumul_pb_red. now exists v, v'. Qed. - Lemma closed_red_refl Γ t : + Lemma closed_red_refl Γ t : is_closed_context Γ -> is_open_term Γ t -> Σ ;;; Γ ⊢ t ⇝ t. Proof using Type. now constructor. Qed. - - Lemma red_decl_refl Γ d : + + Lemma red_decl_refl Γ d : is_closed_context Γ -> ws_decl Γ d -> All_decls (closed_red Σ Γ) d d. @@ -1008,7 +1008,7 @@ Section ContextConversion. eapply ws_cumul_pb_ws_cumul_ctx; tea. now symmetry. Qed. - Lemma ws_cumul_pb_eq_le {Γ t u} : + Lemma ws_cumul_pb_eq_le {Γ t u} : Σ ;;; Γ ⊢ t = u -> Σ ;;; Γ ⊢ t ≤ u. Proof using Type. induction 1. @@ -1019,12 +1019,12 @@ Section ContextConversion. Qed. Hint Resolve ws_cumul_pb_eq_le : pcuic. - Lemma conv_cumul_context {Γ Δ} : + Lemma conv_cumul_context {Γ Δ} : Σ ⊢ Γ ≤[Conv] Δ -> Σ ⊢ Γ ≤[Cumul] Δ. Proof using wfΣ. induction 1; constructor; auto. eapply conv_context_sym in X. - depelim p; constructor; auto. + depelim p; constructor; auto. - now apply ws_cumul_pb_eq_le. - now apply ws_cumul_pb_eq_le. Qed. @@ -1066,7 +1066,7 @@ Section ContextConversion. etransitivity; tea. now eapply (ws_cumul_decls_ws_cumul_ctx X). Qed. - + End ContextConversion. #[global] Hint Resolve isType_open PCUICClosedTyp.wf_local_closed_context : fvs. @@ -1094,10 +1094,10 @@ Proof. - constructor. - constructor; tas. depelim p; constructor; auto; constructor; tas. - eapply eq_term_upto_univ_impl. 5:eauto. all:tea. + eapply eq_term_upto_univ_impl. 5:eauto. all:tea. now transitivity Rle. auto. eapply eq_term_upto_univ_impl; eauto. - eapply eq_term_upto_univ_impl. 5:eauto. all:tea. + eapply eq_term_upto_univ_impl. 5:eauto. all:tea. now transitivity Rle. auto. Qed. @@ -1179,7 +1179,7 @@ Proof. * rewrite !skipn_S. apply IHX. lia. Qed. -Lemma context_cumulativity_wf_app {cf:checker_flags} Σ Γ Γ' Δ : +Lemma context_cumulativity_wf_app {cf:checker_flags} Σ Γ Γ' Δ : cumul_context cumulAlgo_gen Σ Γ' Γ -> wf_local Σ Γ' -> All_local_env @@ -1201,7 +1201,7 @@ Proof. eapply All_local_env_app; split; auto. Qed. -Lemma is_closed_context_cumul_app Γ Δ Γ' : +Lemma is_closed_context_cumul_app Γ Δ Γ' : is_closed_context (Γ ,,, Δ) -> is_closed_context Γ' -> #|Γ| = #|Γ'| -> @@ -1222,25 +1222,25 @@ Qed. #[global] Hint Extern 4 (is_true (on_free_vars_decl (shiftnP _ xpred0) _)) => eapply on_free_vars_decl_eq; [eassumption|len; lia] : fvs. -Lemma ws_cumul_ctx_pb_false_forget {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} : +Lemma ws_cumul_ctx_pb_false_forget {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} : ws_cumul_ctx_pb Conv Σ Γ Γ' -> conv_context cumulAlgo_gen Σ Γ Γ'. Proof. apply: ws_cumul_ctx_pb_forget. Qed. -Lemma ws_cumul_ctx_pb_true_forget {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} : +Lemma ws_cumul_ctx_pb_true_forget {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} : ws_cumul_ctx_pb Cumul Σ Γ Γ' -> cumul_context cumulAlgo_gen Σ Γ Γ'. Proof. apply: ws_cumul_ctx_pb_forget. Qed. -Ltac exass H := +Ltac exass H := match goal with - |- ∑ x : ?A, _ => + |- ∑ x : ?A, _ => assert (H : A); [idtac|exists H] end. -Lemma into_ws_cumul_ctx_pb {cf:checker_flags} {pb : conv_pb} {Σ : global_env_ext} {wfΣ : wf Σ} +Lemma into_ws_cumul_ctx_pb {cf:checker_flags} {pb : conv_pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' : context} : is_closed_context Γ -> is_closed_context Γ' -> @@ -1269,7 +1269,7 @@ Proof. move/on_free_vars_ctx_All_fold: onΔ => onΓ'. destruct X1 as [wsd [wsd' cumd]]. eapply into_ws_cumul_decls; cbn; tea. - rewrite (All2_fold_length X0) //. } + rewrite (All2_fold_length X0) //. } Qed. Lemma ws_cumul_ctx_pb_refl {cf} {Σ} {wfΣ : wf Σ} {pb} {Γ : context} : @@ -1294,10 +1294,10 @@ Proof. now apply ws_cumul_ctx_pb_false_forget. - apply cumul_context_app_same. now apply ws_cumul_ctx_pb_true_forget. - + Qed. -Lemma context_cumulativity_app {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {pb Γ Γ' Δ Δ'} : +Lemma context_cumulativity_app {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {pb Γ Γ' Δ Δ'} : Σ ⊢ Γ' ≤ Γ -> Σ ⊢ Γ ,,, Δ ≤[pb] Γ ,,, Δ' -> Σ ⊢ Γ' ,,, Δ ≤[pb] Γ' ,,, Δ'. @@ -1311,7 +1311,7 @@ Proof. intros. simpl in X1. pose proof (All2_fold_length cum). eapply ws_cumul_decls_ws_cumul_ctx; tea. - eapply ws_cumul_ctx_pb_app_same. + eapply ws_cumul_ctx_pb_app_same. { pose proof (ws_cumul_ctx_pb_closed_left cum). eapply (ws_cumul_decls_inv _ (Γ':=Γ' ,,, Γ0)) in X1 as [isc _]; tea. eapply is_closed_context_cumul_app; tea; try lia. } diff --git a/pcuic/theories/PCUICContextReduction.v b/pcuic/theories/PCUICContextReduction.v index 328c11314..f7d6ef7bc 100644 --- a/pcuic/theories/PCUICContextReduction.v +++ b/pcuic/theories/PCUICContextReduction.v @@ -2,7 +2,7 @@ From Coq Require Import CRelationClasses. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICOnOne PCUICAstUtils PCUICTactics - PCUICLiftSubst PCUICEquality PCUICUnivSubst PCUICInduction + PCUICLiftSubst PCUICEquality PCUICUnivSubst PCUICInduction PCUICReduction PCUICCases PCUICWeakeningConv PCUICWeakeningTyp PCUICTyping PCUICOnFreeVars PCUICSubstitution PCUICRenameDef PCUICRenameConv PCUICInstDef PCUICInstConv. @@ -38,8 +38,8 @@ Section CtxReduction. apply All2_fold_refl => ? ?. apply red_decls_refl. Qed. - - Lemma red_context_app_same {Γ Δ Γ'} : + + Lemma red_context_app_same {Γ Δ Γ'} : red_context Σ Γ Δ -> red_context Σ (Γ ,,, Γ') (Δ ,,, Γ'). Proof using Type. @@ -49,8 +49,8 @@ Section CtxReduction. intros; apply red_decls_refl. Qed. Hint Rewrite inst_case_predicate_context_length : len. - - Lemma on_inst_case_context P Γ pars puinst ctx : + + Lemma on_inst_case_context P Γ pars puinst ctx : on_ctx_free_vars P Γ -> test_context_k (fun k : nat => on_free_vars (closedP k xpredT)) #|pars| ctx -> @@ -61,12 +61,12 @@ Section CtxReduction. relativize #|ctx|; [erewrite on_ctx_free_vars_extend, onΓ|now len]. eapply on_free_vars_ctx_inst_case_context; tea; auto. Qed. - + Ltac inv_on_free_vars ::= match goal with - | [ H : is_true (on_free_vars ?P ?t) |- _ ] => - progress cbn in H; - (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || + | [ H : is_true (on_free_vars ?P ?t) |- _ ] => + progress cbn in H; + (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || eapply forallb_All in H); intros end. @@ -107,7 +107,7 @@ Section CtxReduction. - repeat econstructor; eassumption. - repeat econstructor; eassumption. - eapply red_abs_alt; eauto. - - eapply red_abs_alt; eauto. + - eapply red_abs_alt; eauto. unshelve eapply (IHr (shiftnP 1 P)); tea. 3:repeat (constructor; auto). all:rewrite on_ctx_free_vars_snoc ?onΓ ?onΔ /= //; auto with fvs. @@ -123,7 +123,7 @@ Section CtxReduction. - eapply red_case_p. eapply IHr; tea. 3:now apply red_context_app_same. all:apply on_inst_case_context; tea. - - eapply red_case_c; eauto. + - eapply red_case_c; eauto. - eapply red_case_brs. unfold on_Trel; pcuic. eapply forallb_All in p4. @@ -195,7 +195,7 @@ Section CtxReduction. eapply IHX2; tea. eapply red_on_free_vars in X1; tea. Qed. - Lemma red_context_app {Γ Γ' Δ Δ'} : + Lemma red_context_app {Γ Γ' Δ Δ'} : red_context Σ Γ Δ -> red_context_rel Σ Γ Γ' Δ' -> red_context Σ (Γ ,,, Γ') (Δ ,,, Δ'). @@ -206,7 +206,7 @@ Section CtxReduction. intros h; depelim h; constructor; auto. Qed. - Lemma red_context_app_same_left {Γ Γ' Δ'} : + Lemma red_context_app_same_left {Γ Γ' Δ'} : red_context_rel Σ Γ Γ' Δ' -> red_context Σ (Γ ,,, Γ') (Γ ,,, Δ'). Proof using Type. @@ -214,8 +214,8 @@ Section CtxReduction. eapply All2_fold_app => //. apply red_context_refl. Qed. - - Lemma on_ctx_free_vars_cons P d Γ : + + Lemma on_ctx_free_vars_cons P d Γ : on_ctx_free_vars P (d :: Γ) = on_ctx_free_vars (addnP 1 P) Γ && (P 0 ==> on_free_vars_decl (addnP 1 P) d). Proof using Type. @@ -243,7 +243,7 @@ Section CtxReduction. Qed. Lemma red_context_rel_on_ctx_free_vars {P Γ Δ Δ'} : - on_ctx_free_vars (addnP #|Δ| P) Γ -> + on_ctx_free_vars (addnP #|Δ| P) Γ -> on_ctx_free_vars P Δ -> red_context_rel Σ Γ Δ Δ' -> on_ctx_free_vars P Δ'. @@ -269,9 +269,9 @@ Section CtxReduction. now rewrite on_ctx_free_vars_app onΔ onΓ. Qed. - Definition on_ctx_free_vars_fold P ctx := + Definition on_ctx_free_vars_fold P ctx := All_fold (fun Γ d => - let k := Nat.pred #|ctx| - #|Γ| in + let k := Nat.pred #|ctx| - #|Γ| in P k ==> on_free_vars_decl (addnP (S k) P) d) ctx. Lemma addnP_closedP n P : addnP 1 (closedP (S n) P) =1 closedP n (addnP 1 P). @@ -280,7 +280,7 @@ Section CtxReduction. repeat (PCUICSigmaCalculus.nat_compare_specs => //). Qed. - Lemma red_context_trans Γ Δ Δ' : + Lemma red_context_trans Γ Δ Δ' : on_ctx_free_vars (closedP #|Γ| xpredT) Γ -> red_context Σ Γ Δ -> red_context Σ Δ Δ' -> red_context Σ Γ Δ'. Proof using wfΣ. @@ -309,7 +309,7 @@ Section CtxReduction. move/andP: ond => [] /= //. } Qed. - Lemma red_context_app_right {Γ Γ' Δ Δ'} : + Lemma red_context_app_right {Γ Γ' Δ Δ'} : on_ctx_free_vars (closedP #|Γ ,,, Γ'| xpredT) (Γ ,,, Γ') -> red_context Σ Γ Δ -> red_context_rel Σ Δ Γ' Δ' -> @@ -321,7 +321,7 @@ Section CtxReduction. - eapply red_context_app; [apply red_context_refl|tas]. Qed. - Lemma red_context_rel_inv {Γ Γ' Δ'} : + Lemma red_context_rel_inv {Γ Γ' Δ'} : red_context Σ (Γ ,,, Γ') (Γ ,,, Δ') -> red_context_rel Σ Γ Γ' Δ'. Proof using Type. @@ -329,8 +329,8 @@ Section CtxReduction. eapply All2_fold_app_inv => //. move: (All2_fold_length r). len. Qed. - - (* + + (* intros onΓ r r'. eapply All2_fold_app => //. * now rewrite (All2_fold_length r'). @@ -352,14 +352,14 @@ Section CtxReduction. { rewrite on_ctx_free_vars_app. erewrite onΓ0. now rewrite addnP_add Nat.add_1_r onΔ. } { rewrite on_ctx_free_vars_app. erewrite onΓ0. now rewrite addnP_add Nat.add_1_r onΓ. } Abort. *) - + Lemma OnOne2_local_env_All2_fold {P Q Γ Δ} : OnOne2_local_env P Γ Δ -> (forall Γ d d', P Γ d d' -> Q Γ Γ d d') -> (forall Γ Δ d, Q Γ Δ d d) -> All2_fold Q Γ Δ. Proof using Type. - intros onc HPQ HQ. + intros onc HPQ HQ. induction onc; try constructor; auto. - apply All2_fold_refl => //. - apply All2_fold_refl => //. @@ -396,17 +396,17 @@ Section CtxReduction. econstructor 3; tea. * transitivity (vdef na b' T :: Γ0). + eapply red_one_decl_red_ctx_rel. - do 2 constructor; auto. + do 2 constructor; auto. + transitivity (vdef na b' T' :: Γ0). ++ eapply red_one_decl_red_ctx_rel. - do 2 constructor; auto. + do 2 constructor; auto. ++ rewrite /= on_ctx_free_vars_cons in cl; move/andP: cl=> [] ond cl. specialize (IHX ond). clear -IHX. induction IHX; try now do 2 constructor. econstructor 3; tea. Qed. - -End CtxReduction. + +End CtxReduction. diff --git a/pcuic/theories/PCUICContextSubst.v b/pcuic/theories/PCUICContextSubst.v index 311e85cfb..62ce5a7dc 100644 --- a/pcuic/theories/PCUICContextSubst.v +++ b/pcuic/theories/PCUICContextSubst.v @@ -179,8 +179,8 @@ Qed. #[global] Hint Constructors context_subst : core. -Lemma context_subst_app {ctx ctx' args s} : - context_subst (ctx ++ ctx') args s -> +Lemma context_subst_app {ctx ctx' args s} : + context_subst (ctx ++ ctx') args s -> context_subst (subst_context (skipn #|ctx| s) 0 ctx) (skipn (context_assumptions ctx') args) (firstn #|ctx| s) * context_subst ctx' (firstn (context_assumptions ctx') args) (skipn #|ctx| s). Proof. @@ -196,7 +196,7 @@ Proof. pose proof (context_subst_length2 IHctx). pose proof (context_subst_length2 IHctx'). pose proof (context_subst_length2 Hc). - rewrite context_assumptions_app in H1. + rewrite context_assumptions_app in H1. rewrite firstn_app. rewrite (firstn_0 [a0]). { rewrite firstn_length_le in H0; lia. } rewrite app_nil_r. split; auto. @@ -242,7 +242,7 @@ Proof. pose proof (context_subst_length2 Hc'). rewrite !context_assumptions_app ?app_length ?List.rev_length /= Nat.add_0_r in H. pose proof (context_subst_length2 Hc). lia. - + + specialize (IHtele (vass na ty :: ctx) (args ++ [a]) (a :: s) args' s'). forward IHtele. { econstructor. auto. } rewrite -app_assoc. rewrite -app_comm_cons /=. diff --git a/pcuic/theories/PCUICContexts.v b/pcuic/theories/PCUICContexts.v index 62639a82a..954398a74 100644 --- a/pcuic/theories/PCUICContexts.v +++ b/pcuic/theories/PCUICContexts.v @@ -19,12 +19,12 @@ Implicit Types (cf : checker_flags) (Σ : global_env_ext). #[global] Hint Rewrite Nat.add_0_r : len. -Lemma smash_context_subst_empty s n Γ : +Lemma smash_context_subst_empty s n Γ : smash_context [] (subst_context s n Γ) = subst_context s n (smash_context [] Γ). Proof. apply: (smash_context_subst []). Qed. -Lemma conv_context_smash {cf:checker_flags} Σ Γ Δ Δ' : +Lemma conv_context_smash {cf:checker_flags} Σ Γ Δ Δ' : assumption_context Δ -> All2_fold (fun Δ Δ' => conv_decls cumulSpec0 Σ (Γ ,,, Δ) (Γ ,,, Δ')) Δ Δ' -> assumption_context Δ'. @@ -34,7 +34,7 @@ Proof. depelim Hconv. depelim c; constructor; auto. Qed. -Lemma smash_context_assumption_context {Γ Δ} : +Lemma smash_context_assumption_context {Γ Δ} : assumption_context Γ -> assumption_context (smash_context Γ Δ). Proof. @@ -55,7 +55,7 @@ Hint Resolve smash_context_assumption_context : pcuic. #[global] Hint Constructors assumption_context : pcuic. -Lemma smash_assumption_context Γ : +Lemma smash_assumption_context Γ : assumption_context Γ -> smash_context [] Γ = Γ. Proof. @@ -68,7 +68,7 @@ Proof. reflexivity. Qed. -Lemma smash_context_idempotent Γ : +Lemma smash_context_idempotent Γ : smash_context [] (smash_context [] Γ) = smash_context [] Γ. Proof. rewrite smash_assumption_context //; pcuic. @@ -102,8 +102,8 @@ Proof. + intros l; cbn. now rewrite IHbb. Qed. -Lemma context_subst_lift Γ p s n : - context_subst Γ p s -> +Lemma context_subst_lift Γ p s n : + context_subst Γ p s -> context_subst (lift_context n 0 Γ) (map (lift0 n) p) (map (lift0 n) s). Proof. induction 1 in |- *; try constructor. @@ -120,7 +120,7 @@ Derive Signature for subslet. Lemma closedn_ctx_snoc k Γ d : closedn_ctx k (Γ ,, d) = closedn_ctx k Γ && closed_decl (#|Γ| + k) d. Proof. reflexivity. Qed. -Lemma type_local_ctx_wf_local {cf:checker_flags} Σ Γ Δ s : +Lemma type_local_ctx_wf_local {cf:checker_flags} Σ Γ Δ s : wf_local Σ Γ -> type_local_ctx (lift_typing typing) Σ Γ Δ s -> wf_local Σ (Γ ,,, Δ). @@ -130,7 +130,7 @@ Proof. intros wfΓ wfctx; constructor; intuition auto. exists s; auto. Qed. -Lemma sorts_local_ctx_wf_local {cf:checker_flags} Σ Γ Δ s : +Lemma sorts_local_ctx_wf_local {cf:checker_flags} Σ Γ Δ s : wf_local Σ Γ -> sorts_local_ctx (lift_typing typing) Σ Γ Δ s -> wf_local Σ (Γ ,,, Δ). @@ -153,7 +153,7 @@ Proof. red in isdecl. eapply typing_subst_instance_decl in isdecl; eauto. Qed. -Lemma type_local_ctx_instantiate {cf:checker_flags} Σ ind mdecl Γ Δ u s : +Lemma type_local_ctx_instantiate {cf:checker_flags} Σ ind mdecl Γ Δ u s : wf Σ.1 -> declared_minductive Σ.1 ind mdecl -> type_local_ctx (lift_typing typing) (Σ.1, ind_universes mdecl) Γ Δ s -> @@ -175,12 +175,12 @@ Proof. now rewrite subst_instance_app in Ht. Qed. -Lemma sorts_local_ctx_instantiate {cf:checker_flags} Σ ind mdecl Γ Δ u s : +Lemma sorts_local_ctx_instantiate {cf:checker_flags} Σ ind mdecl Γ Δ u s : wf Σ.1 -> declared_minductive Σ.1 ind mdecl -> sorts_local_ctx (lift_typing typing) (Σ.1, ind_universes mdecl) Γ Δ s -> consistent_instance_ext Σ (ind_universes mdecl) u -> - sorts_local_ctx (lift_typing typing) Σ (subst_instance u Γ) (subst_instance u Δ) + sorts_local_ctx (lift_typing typing) Σ (subst_instance u Γ) (subst_instance u Δ) (List.map (subst_instance_univ u) s). Proof. intros Hctx Hu. @@ -197,7 +197,7 @@ Proof. now rewrite subst_instance_app in b. Qed. -Lemma subst_type_local_ctx {cf:checker_flags} Σ Γ Δ Δ' s ctxs : +Lemma subst_type_local_ctx {cf:checker_flags} Σ Γ Δ Δ' s ctxs : wf Σ.1 -> wf_local Σ (Γ ,,, Δ) -> type_local_ctx (lift_typing typing) Σ (Γ ,,, Δ) Δ' ctxs -> @@ -207,7 +207,7 @@ Proof. induction Δ'; simpl; auto. destruct a as [na [b|] ty]; simpl; intuition auto. + simpl; rewrite subst_context_snoc /= /subst_decl /map_decl /= Nat.add_0_r; - repeat split; tas. + repeat split; tas. - apply infer_typing_sort_impl with id a0; intros Hs. now eapply substitution in Hs. - now eapply substitution in b1. @@ -216,7 +216,7 @@ Proof. eapply substitution in b; eauto. Qed. -Lemma subst_sorts_local_ctx {cf:checker_flags} Σ Γ Δ Δ' s ctxs : +Lemma subst_sorts_local_ctx {cf:checker_flags} Σ Γ Δ Δ' s ctxs : wf Σ.1 -> wf_local Σ (Γ ,,, Δ) -> sorts_local_ctx (lift_typing typing) Σ (Γ ,,, Δ) Δ' ctxs -> @@ -225,7 +225,7 @@ Lemma subst_sorts_local_ctx {cf:checker_flags} Σ Γ Δ Δ' s ctxs : Proof. induction Δ' in ctxs |- *; simpl; auto. destruct a as [na [b|] ty]; simpl; intuition auto. - + simpl; rewrite subst_context_snoc /= /subst_decl /map_decl /= Nat.add_0_r. + + simpl; rewrite subst_context_snoc /= /subst_decl /map_decl /= Nat.add_0_r. repeat split. - now apply IHΔ'. - apply infer_typing_sort_impl with id a0; intros Hs. @@ -237,7 +237,7 @@ Proof. eapply substitution in b; eauto. Qed. -Lemma weaken_type_local_ctx {cf:checker_flags} Σ Γ Γ' Δ ctxs : +Lemma weaken_type_local_ctx {cf:checker_flags} Σ Γ Γ' Δ ctxs : wf Σ.1 -> wf_local Σ Γ -> type_local_ctx (lift_typing typing) Σ Γ' Δ ctxs -> @@ -250,7 +250,7 @@ Proof. all: eapply (weaken_ctx Γ); auto. Qed. -Lemma weaken_sorts_local_ctx {cf:checker_flags} Σ Γ Γ' Δ ctxs : +Lemma weaken_sorts_local_ctx {cf:checker_flags} Σ Γ Γ' Δ ctxs : wf Σ.1 -> wf_local Σ Γ -> sorts_local_ctx (lift_typing typing) Σ Γ' Δ ctxs -> @@ -265,7 +265,7 @@ Proof. all: now eapply (weaken_ctx Γ). Qed. -Lemma reln_app acc Γ Δ k : reln acc k (Γ ++ Δ) = +Lemma reln_app acc Γ Δ k : reln acc k (Γ ++ Δ) = reln (reln acc k Γ) (#|Γ| + k) Δ. Proof. induction Γ in acc, Δ, k |- *; simpl; auto. @@ -277,17 +277,17 @@ Lemma reln_acc acc k Γ : reln acc k Γ = reln [] k Γ ++ acc. Proof. induction Γ in acc, k |- *; simpl; auto. destruct a as [na [b|] ty]. rewrite IHΓ. f_equal. - rewrite IHΓ. rewrite [reln [_] _ _]IHΓ. + rewrite IHΓ. rewrite [reln [_] _ _]IHΓ. now rewrite -app_assoc. Qed. -Lemma to_extended_list_k_app Γ Δ k : to_extended_list_k (Γ ++ Δ) k = +Lemma to_extended_list_k_app Γ Δ k : to_extended_list_k (Γ ++ Δ) k = to_extended_list_k Δ (#|Γ| + k) ++ to_extended_list_k Γ k. Proof. unfold to_extended_list_k. now rewrite reln_app reln_acc. Qed. -Lemma to_extended_list_k_fold_context_k f Γ k : +Lemma to_extended_list_k_fold_context_k f Γ k : to_extended_list_k (fold_context_k f Γ) k = to_extended_list_k Γ k. Proof. rewrite /to_extended_list_k. @@ -296,11 +296,11 @@ Proof. simpl; auto. intros. rewrite fold_context_k_snoc0. simpl. - destruct a as [? [?|] ?] => /=; now rewrite IHΓ. + destruct a as [? [?|] ?] => /=; now rewrite IHΓ. Qed. -Lemma to_extended_list_k_lift_context c k n k' : - to_extended_list_k (lift_context n k c) k' = to_extended_list_k c k'. +Lemma to_extended_list_k_lift_context c k n k' : + to_extended_list_k (lift_context n k c) k' = to_extended_list_k c k'. Proof. now rewrite to_extended_list_k_fold_context_k. Qed. Lemma reln_lift n k Γ : reln [] (n + k) Γ = map (lift0 n) (reln [] k Γ). @@ -319,7 +319,7 @@ Hint Rewrite to_extended_list_length : len. Lemma map_subst_app_to_extended_list_k s s' ctx k : k = #|s| -> - map (subst0 (s ++ s')) (to_extended_list_k ctx k) = + map (subst0 (s ++ s')) (to_extended_list_k ctx k) = map (subst0 s') (to_extended_list_k ctx 0). Proof. intros ->. @@ -330,9 +330,9 @@ Proof. f_equal. rewrite -{1}(Nat.add_0_r #|s|) simpl_subst' ?lift0_id //. now rewrite map_length. Qed. - + Lemma subst_context_smash_context s k Γ Δ : - subst_context s k (smash_context Γ Δ) = + subst_context s k (smash_context Γ Δ) = smash_context (subst_context s (#|Δ| + k) Γ) (subst_context s k Δ). Proof. induction Δ as [|[? [] ?] ?] in Γ |- *; simpl; auto; @@ -352,7 +352,7 @@ Section WfEnv. Context {cf} {Σ} {wfΣ : wf Σ}. Lemma wf_local_rel_smash_context_gen {Γ Δ Δ'} : - wf_local Σ (Δ' ,,, Γ) -> + wf_local Σ (Δ' ,,, Γ) -> wf_local_rel Σ (Δ' ,,, Γ) Δ -> wf_local_rel Σ Δ' (smash_context Δ Γ). Proof using wfΣ. @@ -374,16 +374,16 @@ Section WfEnv. Qed. Lemma wf_local_rel_smash_context {Γ Δ} : - wf_local Σ (Δ ,,, Γ) -> + wf_local Σ (Δ ,,, Γ) -> wf_local_rel Σ Δ (smash_context [] Γ). Proof using wfΣ. intros. eapply wf_local_rel_smash_context_gen; eauto. constructor. Qed. - Lemma wf_local_smash_end Γ Δ : + Lemma wf_local_smash_end Γ Δ : wf_local Σ (Γ ,,, Δ) -> wf_local Σ (Γ ,,, smash_context [] Δ). Proof using wfΣ. - intros wf. + intros wf. apply All_local_env_app. split. now apply All_local_env_app_inv in wf. eapply wf_local_rel_smash_context; auto. @@ -409,7 +409,7 @@ End WfEnv. Local Open Scope sigma_scope. -Lemma context_subst_extended_subst Γ args s : +Lemma context_subst_extended_subst Γ args s : context_subst Γ args s -> s = map (inst (List.rev args ⋅n ids)) (extended_subst Γ 0). Proof. @@ -467,7 +467,7 @@ Proof. Qed. Lemma extended_subst_to_extended_list_k Γ k : - (map (subst (extended_subst Γ 0) k) (to_extended_list_k Γ k)) = + (map (subst (extended_subst Γ 0) k) (to_extended_list_k Γ k)) = to_extended_list_k (smash_context [] Γ) k. Proof. unfold to_extended_list_k. @@ -476,12 +476,12 @@ Proof. - rewrite smash_context_acc //. rewrite reln_app. autorewrite with len. simpl. rewrite -IHΓ //. rewrite Nat.add_1_r. - rewrite (reln_lift 1). + rewrite (reln_lift 1). clear. rewrite (map_subst_app_decomp [_]). rewrite -map_map_compose. f_equal. simpl. - generalize (lift0 #|extended_subst Γ 0| + generalize (lift0 #|extended_subst Γ 0| (subst0 (extended_subst Γ 0) (lift (context_assumptions Γ) #|Γ| t))). intros t0. change 1 with #|[t0]|. @@ -498,7 +498,7 @@ Proof. - rewrite smash_context_acc //. simpl. rewrite reln_acc map_app. - rewrite (reln_acc [_] _ (smash_context [] Γ)). + rewrite (reln_acc [_] _ (smash_context [] Γ)). simpl. rewrite Nat.leb_refl Nat.sub_diag /=. f_equal. rewrite -IHΓ //. 2:{ do 2 f_equal; lia. } @@ -519,12 +519,12 @@ Qed. Lemma assumption_context_fold f Γ : assumption_context Γ -> assumption_context (fold_context_k f Γ). -Proof. +Proof. induction 1; simpl. constructor. rewrite fold_context_k_snoc0. now constructor. Qed. -Lemma smash_context_app_expand Γ Δ Δ' : +Lemma smash_context_app_expand Γ Δ Δ' : smash_context Γ (Δ ,,, Δ') = smash_context [] Δ ,,, expand_lets_ctx Δ (smash_context Γ Δ'). Proof. @@ -532,8 +532,8 @@ Proof. rewrite /expand_lets_k_ctx /app_context. f_equal. Qed. -Lemma expand_lets_smash_context Γ Δ Δ' : - expand_lets_ctx Γ (smash_context Δ Δ') = +Lemma expand_lets_smash_context Γ Δ Δ' : + expand_lets_ctx Γ (smash_context Δ Δ') = smash_context (expand_lets_k_ctx Γ #|Δ'| Δ) (expand_lets_ctx Γ Δ'). Proof. rewrite /expand_lets_ctx /expand_lets_k_ctx. @@ -546,16 +546,16 @@ Proof. reflexivity. Qed. Lemma expand_lets_ctx_nil Γ : expand_lets_ctx Γ [] = []. Proof. reflexivity. Qed. #[global] -Hint Rewrite expand_lets_k_ctx_nil expand_lets_ctx_nil : pcuic. +Hint Rewrite expand_lets_k_ctx_nil expand_lets_ctx_nil : pcuic. -Definition subst_let_expand args Δ T := +Definition subst_let_expand args Δ T := (subst0 args (expand_lets Δ T)). -Definition subst_context_let_expand args Δ Γ := +Definition subst_context_let_expand args Δ Γ := (subst_context args 0 (expand_lets_ctx Δ Γ)). - + Definition subst_let_expand_tProd args Δ na T s : - subst_let_expand args Δ (tProd na T (tSort s)) = + subst_let_expand args Δ (tProd na T (tSort s)) = tProd na (subst_let_expand args Δ T) (tSort s). Proof. reflexivity. @@ -573,9 +573,9 @@ Definition subst_let_expand_tInd s Δ ind u : subst_let_expand s Δ (tInd ind u) = tInd ind u. Proof. reflexivity. Qed. -Lemma subst_let_expand_it_mkProd_or_LetIn s Γ Δ u : +Lemma subst_let_expand_it_mkProd_or_LetIn s Γ Δ u : subst_let_expand s Γ (it_mkProd_or_LetIn Δ (tSort u)) = - it_mkProd_or_LetIn (subst_context_let_expand s Γ Δ) (tSort u). + it_mkProd_or_LetIn (subst_context_let_expand s Γ Δ) (tSort u). Proof. rewrite /subst_let_expand /expand_lets. rewrite expand_lets_it_mkProd_or_LetIn /= subst_it_mkProd_or_LetIn /=. @@ -629,12 +629,12 @@ Qed. Lemma untyped_subslet_extended_subst Γ Δ : untyped_subslet (Γ ,,, smash_context [] Δ) - (extended_subst Δ 0) + (extended_subst Δ 0) (lift_context (context_assumptions Δ) 0 Δ). Proof. induction Δ as [|[na [d|] ?] ?]; simpl; try constructor. * rewrite lift_context_snoc /lift_decl /= /map_decl /=. - len. + len. constructor => //. * rewrite smash_context_acc. simpl. rewrite /map_decl /= /map_decl /=. simpl. @@ -644,12 +644,12 @@ Proof. rewrite -(lift_context_lift_context 1 _). eapply (untyped_subslet_lift _ [_]); eauto. Qed. - + Lemma subslet_extended_subst {cf} {Σ} {wfΣ : wf Σ} Γ Δ : wf_local Σ (Γ ,,, Δ) -> subslet Σ (Γ ,,, smash_context [] Δ) - (extended_subst Δ 0) + (extended_subst Δ 0) (lift_context (context_assumptions Δ) 0 Δ). Proof. move=> wfΔ. @@ -658,7 +658,7 @@ Proof. * depelim wfΔ. repeat red in l, l0. specialize (IHΔ wfΔ). rewrite lift_context_snoc /lift_decl /= /map_decl /=. - len. + len. constructor => //. eapply (weakening_typing (Γ'' := smash_context [] Δ)) in l0. len in l0. simpl in l0. simpl. @@ -694,9 +694,9 @@ Proof. now rewrite simpl_lift; try lia. Qed. -Lemma typing_expand_lets {cf} {Σ} {wfΣ : wf Σ} Γ Δ t T : - Σ ;;; Γ ,,, Δ |- t : T -> - Σ ;;; Γ ,,, smash_context [] Δ |- expand_lets Δ t : expand_lets Δ T. +Lemma typing_expand_lets {cf} {Σ} {wfΣ : wf Σ} Γ Δ t T : + Σ ;;; Γ ,,, Δ |- t : T -> + Σ ;;; Γ ,,, smash_context [] Δ |- expand_lets Δ t : expand_lets Δ T. Proof. intros Ht. rewrite /expand_lets /expand_lets_k. @@ -708,7 +708,7 @@ Proof. now eapply subslet_extended_subst. Qed. -Lemma subst_context_let_expand_length s Γ Δ : +Lemma subst_context_let_expand_length s Γ Δ : #|subst_context_let_expand s Γ Δ| = #|Δ|. Proof. now rewrite /subst_context_let_expand; len. @@ -716,8 +716,8 @@ Qed. #[global] Hint Rewrite subst_context_let_expand_length : len. -Lemma to_extended_list_subst_context_let_expand s Γ Δ : - to_extended_list (subst_context_let_expand s Γ Δ) = +Lemma to_extended_list_subst_context_let_expand s Γ Δ : + to_extended_list (subst_context_let_expand s Γ Δ) = to_extended_list Δ. Proof. rewrite /subst_context_let_expand /to_extended_list /expand_lets_ctx /expand_lets_k_ctx. @@ -738,7 +738,7 @@ Qed. Notation eq_names := (All2 (fun x y => x = (decl_name y))). -Lemma eq_names_subst_context nas Γ s k : +Lemma eq_names_subst_context nas Γ s k : eq_names nas Γ -> eq_names nas (subst_context s k Γ). Proof. @@ -747,7 +747,7 @@ Proof. * rewrite subst_context_snoc. constructor; auto. Qed. -Lemma eq_names_subst_instance nas Γ u : +Lemma eq_names_subst_instance nas Γ u : eq_names nas Γ -> eq_names nas (subst_instance u Γ). Proof. diff --git a/pcuic/theories/PCUICConvCumInversion.v b/pcuic/theories/PCUICConvCumInversion.v index eb371d645..b36844fc7 100644 --- a/pcuic/theories/PCUICConvCumInversion.v +++ b/pcuic/theories/PCUICConvCumInversion.v @@ -1,7 +1,7 @@ From Coq Require Import ssreflect ssrbool. From Equations Require Import Equations. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICContextConversion PCUICContextReduction - PCUICCumulativity PCUICConversion PCUICEquality PCUICLiftSubst PCUICNormal PCUICReduction PCUICTyping + PCUICCumulativity PCUICConversion PCUICEquality PCUICLiftSubst PCUICNormal PCUICReduction PCUICTyping PCUICGlobalEnv PCUICConfluence PCUICSubstitution PCUICClosed PCUICClosedTyp PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICWellScopedCumulativity PCUICOnFreeVars PCUICSR. @@ -27,7 +27,7 @@ Proof. apply eq_term_upto_univ_leq; cbn; auto. Qed. -Lemma alt_into_ws_cumul_pb_terms {cf Σ} {wfΣ : wf Σ} {Γ l l'} : +Lemma alt_into_ws_cumul_pb_terms {cf Σ} {wfΣ : wf Σ} {Γ l l'} : All2 (convAlgo Σ Γ) l l' -> is_closed_context Γ -> forallb (is_open_term Γ) l -> @@ -36,7 +36,7 @@ Lemma alt_into_ws_cumul_pb_terms {cf Σ} {wfΣ : wf Σ} {Γ l l'} : Proof. solve_all. eapply into_ws_cumul_pb; tea. Qed. - + (** Might be better suited with [red_context] hyps ensuring closedness directly *) Lemma red_ctx_rel_par_conv {cf Σ Γ Γ0 Γ0' Γ1 Γ1'} {wfΣ : wf Σ} : is_closed_context (Γ ,,, Γ0) -> @@ -63,7 +63,7 @@ Proof. now symmetry. Qed. -Lemma into_red_terms {Σ Γ ts ts'} : +Lemma into_red_terms {Σ Γ ts ts'} : All2 (red Σ Γ) ts ts' -> is_closed_context Γ -> forallb (is_open_term Γ) ts -> @@ -72,8 +72,8 @@ Proof. induction 1; [constructor|]. move=> /= clΓ /andP[clx cll]. constructor; eauto using into_closed_red. Qed. - -Lemma alpha_eq_context_gen Γ Δ : + +Lemma alpha_eq_context_gen Γ Δ : eq_context_upto_names Γ Δ -> eq_context_gen eq eq Γ Δ. Proof. @@ -126,7 +126,7 @@ Proof. { eapply PCUICContexts.smash_context_assumption_context => //. constructor. } have lenpars' : #|pars| = context_assumptions (smash_context [] (ind_params mdecl)). { rewrite context_assumptions_smash_context /= //. } - eapply (substitution_ws_cumul_ctx_pb_subst_conv (Γ'':=[]) + eapply (substitution_ws_cumul_ctx_pb_subst_conv (Γ'':=[]) (Γ' := smash_context [] mdecl.(ind_params)) (Γ'0 := smash_context [] mdecl.(ind_params))) => //. * eapply (PCUICSpine.ws_cumul_ctx_pb_rel_trans (Δ' := ctx'@[puinst])). @@ -199,7 +199,7 @@ Section fixed. Context {cf : checker_flags}. Context (Σ : global_env_ext). Context (wfΣ : ∥ wf Σ ∥). - + Definition isIndConstructApp (t : term) : bool := match (decompose_app t).1 with | tInd _ _ @@ -229,7 +229,7 @@ Section fixed. - discriminate not_ind. - discriminate not_ind. Qed. - + Lemma whnf_red_isIndConstructApp Γ t t' : whnf_red Σ Γ t t' -> isIndConstructApp t' = isIndConstructApp t. @@ -239,7 +239,7 @@ Section fixed. rewrite (isIndConstructApp_mkApps _ [arg']) (isIndConstructApp_mkApps _ [arg]). apply IHr. Qed. - + Lemma eq_termp_mkApps_inv leq v args v' args' : isApp v = false -> isApp v' = false -> @@ -249,7 +249,7 @@ Section fixed. intros noapp1 noapp2 eq. apply eq_term_upto_univ_mkApps_inv in eq as (?&?) => //. Qed. - + Definition conv_cum_napp leq Γ napp t t' := match t with | tInd _ _ @@ -267,7 +267,7 @@ Section fixed. Proof using wfΣ. intros conv notapp notapp' wh wh'. eapply conv_cum_alt in conv as [(?&?&[r1 r2 e])]; auto. - sq. + sq. pose proof (whnf_red_inv _ _ _ _ wh r1) as w1. apply whnf_red_mkApps_l_inv in w1 as (?&?&->&?&?); auto. pose proof (whnf_red_inv _ _ _ _ wh' r2) as w2. @@ -347,7 +347,7 @@ Section fixed. have clred' : red_terms Σ Γ (pparams p') motivepars0. { eapply into_red_terms; tea. } have eqpars : ws_cumul_pb_terms Σ Γ (pparams p) (pparams p'). - { etransitivity => //. + { etransitivity => //. { eapply red_terms_ws_cumul_pb_terms; tea. } transitivity motivepars0. { eapply eq_terms_ws_cumul_pb_terms; fvs. @@ -359,16 +359,16 @@ Section fixed. { apply (wf_predicate_length_pars wfp). } { apply (wf_predicate_length_pars wfp'). } } repeat split; eauto. - - transitivity motiveret0. + - transitivity motiveret0. { eapply ws_cumul_pb_alt_closed. exists motiveret, motiveret0. - split; auto. + split; auto. * split; auto. - + rewrite on_free_vars_ctx_app. apply /andP. split; auto. + + rewrite on_free_vars_ctx_app. apply /andP. split; auto. eapply on_free_vars_ctx_inst_case_context; tea => //. rewrite test_context_k_closed_on_free_vars_ctx //. + len. now setoid_rewrite shiftnP_add in p6. * eapply closed_red_refl. - + rewrite on_free_vars_ctx_app. apply /andP. split; auto. + + rewrite on_free_vars_ctx_app. apply /andP. split; auto. eapply on_free_vars_ctx_inst_case_context; tea => //. now rewrite test_context_k_closed_on_free_vars_ctx. + eapply red_on_free_vars in r1; tea. @@ -394,7 +394,7 @@ Section fixed. destruct p0, p1, r. cbn in p4, p9. move/andP: p4 => [fv p4]. move/andP: p9 => [fv' p9]. - constructor. + constructor. 2: { apply IHbrseq; auto. } have eqctx : Σ ⊢ Γ ,,, inst_case_branch_context p x0 = Γ ,,, inst_case_branch_context p' x1. { rewrite /inst_case_branch_context. @@ -427,11 +427,11 @@ Section fixed. 1:now eapply ws_cumul_ctx_pb_closed_right in eqctx. move/andP: fv => []. len. now rewrite shiftnP_add. Qed. - + Lemma conv_cum_tFix_inv leq Γ mfix idx mfix' idx' : conv_cum leq Σ Γ (tFix mfix idx) (tFix mfix' idx') -> ∥idx = idx' × - All2 (fun d d' => + All2 (fun d d' => [× rarg d = rarg d', eq_binder_annot d.(dname) d'.(dname), Σ;;; Γ ⊢ dtype d = dtype d' & @@ -478,7 +478,7 @@ Section fixed. destruct r as ((?&(((? & ?) & ?)&?))&?), p as (?&?&?&?&?), p0 as (?&?&?&?&?). split; auto; try congruence. - eapply ws_cumul_pb_alt_closed; exists (dtype x), (dtype y). split; eauto. - all:eapply into_closed_red; eauto. + all:eapply into_closed_red; eauto. { now move/andP: i1. } { now move/andP: i2. } - eapply ws_cumul_pb_alt_closed. @@ -494,7 +494,7 @@ Section fixed. Lemma conv_cum_tCoFix_inv leq Γ mfix idx mfix' idx' : conv_cum leq Σ Γ (tCoFix mfix idx) (tCoFix mfix' idx') -> ∥idx = idx' × - All2 (fun d d' => + All2 (fun d d' => [× rarg d = rarg d', eq_binder_annot d.(dname) d'.(dname), Σ;;; Γ ⊢ dtype d = dtype d' & @@ -538,7 +538,7 @@ Section fixed. destruct r as ((?&(((? & ?) & ?)&?))&?), p as (?&?&?&?&?), p0 as (?&?&?&?&?). split; auto; try congruence. - eapply ws_cumul_pb_alt_closed; exists (dtype x), (dtype y). split; eauto. - all:eapply into_closed_red; eauto. + all:eapply into_closed_red; eauto. { now move/andP: i1. } { now move/andP: i2. } - eapply ws_cumul_pb_alt_closed. @@ -569,8 +569,8 @@ Section fixed. depelim c0. split; [easy|]. apply ws_cumul_pb_alt_closed; eauto. - exists c'0, c'1; split; eauto. + exists c'0, c'1; split; eauto. all:eapply into_closed_red; eauto. Qed. - + End fixed. diff --git a/pcuic/theories/PCUICConversion.v b/pcuic/theories/PCUICConversion.v index ed537161d..e7baf4bec 100644 --- a/pcuic/theories/PCUICConversion.v +++ b/pcuic/theories/PCUICConversion.v @@ -22,7 +22,7 @@ Require Import Equations.Prop.DepElim. This files derives the injectivity of type constructors for conversion/cumulativity and the discrimination of Sorts, Products and Inductive types. It also shows that conversion - is properly congruent for all type and term constructors, as long as we are considering + is properly congruent for all type and term constructors, as long as we are considering *well-scoped* objects. *) @@ -67,94 +67,94 @@ Section CumulSpecIsCumulAlgo. Proposition red1_cumulSpec (Γ : context) (M N : term) : Σ ;;; Γ |- M ⇝ N -> Σ ;;; Γ |- M =s N. - Proof. + Proof. intro r. induction r using red1_ind_all; try (econstructor; eauto; reflexivity). - - eapply cumul_Case; try reflexivity. - * destruct p as [p x]. cbn in *. try repeat split; cbn; try reflexivity. + - eapply cumul_Case; try reflexivity. + * destruct p as [p x]. cbn in *. try repeat split; cbn; try reflexivity. change (fun t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) with (convSpec Σ Γ). induction X; econstructor; try reflexivity; try eassumption. exact (p.2). * apply All2_reflexivity. eapply Prod_reflexivity; intro x; reflexivity. - - eapply cumul_Case; try reflexivity. - * change (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) with (convSpec Σ). - destruct p as [p x]. cbn in *. try repeat split; cbn; try reflexivity; eauto. - * apply All2_reflexivity. eapply Prod_reflexivity; intro x; reflexivity. - - eapply cumul_Case; try reflexivity. + - eapply cumul_Case; try reflexivity. + * change (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) with (convSpec Σ). + destruct p as [p x]. cbn in *. try repeat split; cbn; try reflexivity; eauto. + * apply All2_reflexivity. eapply Prod_reflexivity; intro x; reflexivity. + - eapply cumul_Case; try reflexivity. * change (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) with (convSpec Σ). - destruct p as [p x]. cbn in *. try repeat split; cbn; try reflexivity; eauto. + destruct p as [p x]. cbn in *. try repeat split; cbn; try reflexivity; eauto. * eauto. - * apply All2_reflexivity. eapply Prod_reflexivity; intro x; reflexivity. - - eapply cumul_Case; try reflexivity. + * apply All2_reflexivity. eapply Prod_reflexivity; intro x; reflexivity. + - eapply cumul_Case; try reflexivity. * change (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) with (convSpec Σ). - destruct p as [p x]. cbn in *. try repeat split; cbn; try reflexivity; eauto. + destruct p as [p x]. cbn in *. try repeat split; cbn; try reflexivity; eauto. * induction X; econstructor. - + destruct p0 as [ [ _ hbody ] hhd ]. rewrite hhd. split; eauto. reflexivity. + + destruct p0 as [ [ _ hbody ] hhd ]. rewrite hhd. split; eauto. reflexivity. + apply All2_reflexivity. eapply Prod_reflexivity; intro x; reflexivity. - + split; reflexivity. - + exact IHX. + + split; reflexivity. + + exact IHX. - eapply cumul_Evar. change (fun t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) with (convSpec Σ Γ). - induction X; econstructor; eauto; try reflexivity. + induction X; econstructor; eauto; try reflexivity. * exact p.2. - - eapply cumul_Fix. set (mfixAbs := mfix0). unfold mfixAbs at 2. clearbody mfixAbs. + - eapply cumul_Fix. set (mfixAbs := mfix0). unfold mfixAbs at 2. clearbody mfixAbs. induction X; econstructor; eauto; try reflexivity. - * destruct p as [ [ _ hdtype ] e ]. - pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). - pose proof (edname := fst_eq (fst_eq e)). clear e. destruct erarg, edbody, edname. + * destruct p as [ [ _ hdtype ] e ]. + pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). + pose proof (edname := fst_eq (fst_eq e)). clear e. destruct erarg, edbody, edname. repeat split; eauto ; try reflexivity. * apply All2_reflexivity. repeat eapply Prod_reflexivity; intro x; reflexivity. * repeat split; reflexivity. - - eapply cumul_Fix. set (mfixAbs := mfix0). unfold mfixAbs at 2. - assert (Habs : mfixAbs = mfix0) by reflexivity. clearbody mfixAbs. + - eapply cumul_Fix. set (mfixAbs := mfix0). unfold mfixAbs at 2. + assert (Habs : mfixAbs = mfix0) by reflexivity. clearbody mfixAbs. induction X; destruct Habs; econstructor; eauto; try reflexivity. - * destruct p as [ [ _ hdtype ] e ]. - pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). - pose proof (edname := fst_eq (fst_eq e)). clear e. destruct erarg, edbody, edname. - repeat split; eauto ; try reflexivity. + * destruct p as [ [ _ hdtype ] e ]. + pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). + pose proof (edname := fst_eq (fst_eq e)). clear e. destruct erarg, edbody, edname. + repeat split; eauto ; try reflexivity. * apply All2_reflexivity. repeat eapply Prod_reflexivity; intro x; reflexivity. - * repeat split; reflexivity. - - eapply cumul_CoFix. set (mfixAbs := mfix0). unfold mfixAbs at 2. clearbody mfixAbs. + * repeat split; reflexivity. + - eapply cumul_CoFix. set (mfixAbs := mfix0). unfold mfixAbs at 2. clearbody mfixAbs. induction X; econstructor; eauto; try reflexivity. - * destruct p as [ [ _ hdtype ] e ]. - pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). - pose proof (edname := fst_eq (fst_eq e)). clear e. destruct erarg, edbody, edname. + * destruct p as [ [ _ hdtype ] e ]. + pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). + pose proof (edname := fst_eq (fst_eq e)). clear e. destruct erarg, edbody, edname. repeat split; eauto ; try reflexivity. * apply All2_reflexivity. repeat eapply Prod_reflexivity; intro x; reflexivity. * repeat split; reflexivity. - - eapply cumul_CoFix. set (mfixAbs := mfix0). unfold mfixAbs at 2. - assert (Habs : mfixAbs = mfix0) by reflexivity. clearbody mfixAbs. + - eapply cumul_CoFix. set (mfixAbs := mfix0). unfold mfixAbs at 2. + assert (Habs : mfixAbs = mfix0) by reflexivity. clearbody mfixAbs. induction X; destruct Habs; econstructor; eauto; try reflexivity. - * destruct p as [ [ _ hdtype ] e ]. - pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). - pose proof (edname := fst_eq (fst_eq e)). clear e. destruct erarg, edbody, edname. - repeat split; eauto ; try reflexivity. + * destruct p as [ [ _ hdtype ] e ]. + pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). + pose proof (edname := fst_eq (fst_eq e)). clear e. destruct erarg, edbody, edname. + repeat split; eauto ; try reflexivity. * apply All2_reflexivity. repeat eapply Prod_reflexivity; intro x; reflexivity. * repeat split; reflexivity. - Defined. + Defined. Proposition convSpec_cumulSpec (Γ : context) (M N : term) : Σ ;;; Γ |- M =s N -> Σ ;;; Γ |- M <=s N. - Proof. + Proof. intro Hconv. apply cumul_Sym. apply cumul_Sym. assumption. - Defined. + Defined. Proposition cumul_mkApps (Γ : context) {pb} M N args args' : - cumulSpec0 Σ Γ pb M N -> + cumulSpec0 Σ Γ pb M N -> All2 (cumulSpec0 Σ Γ Conv) args args' -> cumulSpec0 Σ Γ pb (mkApps M args) (mkApps N args'). Proof. intros HMN Hargs. revert M N HMN; induction Hargs; intros. - eassumption. - cbn. eapply IHHargs. eapply cumul_App; eauto. - Defined. + Defined. Ltac try_with_nil := match goal with H : _ |- _ => eapply (H _ _ _ [] []); eauto end. Proposition eq_term_upto_univ_napp_cumulSpec (Γ : context) {pb} M N args args' : - compare_term_napp pb Σ Σ #|args| M N -> + compare_term_napp pb Σ Σ #|args| M N -> All2 (cumulSpec0 Σ Γ Conv) args args' -> cumulSpec0 Σ Γ pb (mkApps M args) (mkApps N args'). - Proof. - induction M in Γ, pb, N , args, args' |- * using term_forall_list_ind ; intros H Hargs; depelim H; + Proof. + induction M in Γ, pb, N , args, args' |- * using term_forall_list_ind ; intros H Hargs; depelim H; try (solve [eapply cumul_mkApps; eauto ; econstructor; eauto; try_with_nil]). - apply cumul_mkApps; eauto. eapply All2_All_mix_left in X. 2: tea. eapply cumul_Evar. eapply All2_impl; try exact X. cbv beta. intuition. @@ -180,25 +180,25 @@ Section CumulSpecIsCumulAlgo. - apply cumul_mkApps; eauto. eapply cumul_CoFix. unfold tFixProp in *. eapply All2_All_mix_left in X. 2: tea. eapply All2_impl; try exact X. cbv beta. intuition; try_with_nil. Defined. - + Proposition eq_term_upto_univ_cumulSpec (Γ : context) {pb} M N : compare_term pb Σ Σ M N -> cumulSpec0 Σ Γ pb M N. Proof. - intros. eapply (eq_term_upto_univ_napp_cumulSpec _ _ _ [] []); eauto. - Defined. + intros. eapply (eq_term_upto_univ_napp_cumulSpec _ _ _ [] []); eauto. + Defined. Proposition cumulAlgo_cumulSpec {pb} (Γ : context) (M N : term) : Σ ;;; Γ ⊢ M ≤[pb] N -> Σ ;;; Γ ⊢ M ≤s[pb] N. - Proof. + Proof. induction 1. - - destruct pb; eapply eq_term_upto_univ_cumulSpec; eauto. - - destruct pb; revgoals. + - destruct pb; eapply eq_term_upto_univ_cumulSpec; eauto. + - destruct pb; revgoals. * eapply cumul_Trans; eauto. apply convSpec_cumulSpec. apply red1_cumulSpec ; assumption. * eapply cumul_Trans; eauto. apply red1_cumulSpec ; assumption. - - destruct pb; revgoals. + - destruct pb; revgoals. * eapply cumul_Trans; eauto. apply cumul_Sym. apply red1_cumulSpec ; assumption. * eapply cumul_Trans; eauto. apply cumul_Sym. apply red1_cumulSpec ; assumption. - Defined. + Defined. End CumulSpecIsCumulAlgo. @@ -220,20 +220,20 @@ Proof. - cbn. rewrite IHl. reflexivity. Qed. -Lemma on_fvs_prod {n na M1 M2} : - on_free_vars (shiftnP n xpred0) (tProd na M1 M2) = +Lemma on_fvs_prod {n na M1 M2} : + on_free_vars (shiftnP n xpred0) (tProd na M1 M2) = on_free_vars (shiftnP n xpred0) M1 && on_free_vars (shiftnP (S n) xpred0) M2. Proof. cbn. rewrite shiftnP_add. reflexivity. Qed. -Lemma on_fvs_lambda {n na M1 M2} : - on_free_vars (shiftnP n xpred0) (tLambda na M1 M2) = +Lemma on_fvs_lambda {n na M1 M2} : + on_free_vars (shiftnP n xpred0) (tLambda na M1 M2) = on_free_vars (shiftnP n xpred0) M1 && on_free_vars (shiftnP (S n) xpred0) M2. Proof. cbn. rewrite shiftnP_add. reflexivity. Qed. -Lemma on_fvs_letin {n na M1 M2 M3} : - on_free_vars (shiftnP n xpred0) (tLetIn na M1 M2 M3) = +Lemma on_fvs_letin {n na M1 M2 M3} : + on_free_vars (shiftnP n xpred0) (tLetIn na M1 M2 M3) = [&& on_free_vars (shiftnP n xpred0) M1, on_free_vars (shiftnP n xpred0) M2 & on_free_vars (shiftnP (S n) xpred0) M3]. @@ -256,7 +256,7 @@ Ltac fvs := eauto 10 with fvs. Section ConvCongruences. Context {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}. - + Lemma into_closed_red {Γ t u} : red Σ Γ t u -> is_closed_context Γ -> @@ -360,7 +360,7 @@ Section ConvCongruences. eapply red_step with v; eauto with fvs. - depelim r. solve_discr. Qed. - + (* #[global] Instance red_decls_refl Γ Δ : Reflexive (red_decls Σ Γ Δ). Proof. @@ -372,7 +372,7 @@ Section ConvCongruences. Proof. intros x. eapply All2_fold_refl. intros. apply All_decls_refl. Qed. *) - + (* Lemma clos_rt_monotone_hetero {A B} (R : relation A) (S : relation B) (f : A -> B) : (forall x y, R x y -> on_Trel S f x y) -> (forall x y, R x y -> inclusion (clos_refl_trans R) (clos_refl_trans S). *) @@ -388,7 +388,7 @@ Section ConvCongruences. destruct y as [y hy]; econstructor 3; [eapply IHr1|eapply IHr2]; reflexivity. Qed. - Lemma on_free_vars_subst {Γ Γ' : context} {s b} : + Lemma on_free_vars_subst {Γ Γ' : context} {s b} : forallb (on_free_vars (shiftnP #|Γ| xpred0)) s -> on_free_vars (shiftnP (#|Γ| + #|s| + #|Γ'|) xpred0) b -> on_free_vars (shiftnP (#|Γ'| + #|Γ|) xpred0) (subst s #|Γ'| b). @@ -438,7 +438,7 @@ Section ConvCongruences. intros. now eapply is_open_term_subst_gen; tea. Qed. - Lemma closed_red_red_subst {Γ Δ Γ' s s' b} : + Lemma closed_red_red_subst {Γ Δ Γ' s s' b} : is_closed_context (Γ ,,, Δ ,,, Γ') -> All2 (closed_red Σ Γ) s s' -> untyped_subslet Γ s Δ -> @@ -458,7 +458,7 @@ Section ConvCongruences. rewrite Nat.add_assoc -shiftnP_add addnP_shiftnP; eauto with fvs. Qed. - Lemma closed_red_red_subst0 {Γ Δ s s' b} : + Lemma closed_red_red_subst0 {Γ Δ s s' b} : is_closed_context (Γ ,,, Δ) -> All2 (closed_red Σ Γ) s s' -> untyped_subslet Γ s Δ -> @@ -469,7 +469,7 @@ Section ConvCongruences. Qed. Hint Resolve closed_red_red : pcuic. - + (*Inductive closed_subslet (Γ : context) : list term -> context -> Type := | closed_emptyslet : closed_subslet Γ [] [] | closed_cons_let_ass Δ s na t T : @@ -480,8 +480,8 @@ Section ConvCongruences. closed_subslet Γ s Δ -> is_open_term Γ (subst0 s t) -> closed_subslet Γ (subst0 s t :: s) (Δ ,, vdef na t T). - - Lemma closed_subslet_untyped_subslet {Γ s Δ} : + + Lemma closed_subslet_untyped_subslet {Γ s Δ} : closed_subslet Γ s Δ -> untyped_subslet Γ s Δ. Proof. @@ -656,7 +656,7 @@ Section ConvCongruences. Lemma ws_cumul_pb_Prod_l_inv {pb Γ na dom codom T} : Σ ;;; Γ ⊢ tProd na dom codom ≤[pb] T -> - ∑ na' dom' codom', + ∑ na' dom' codom', [× Σ ;;; Γ ⊢ T ⇝ (tProd na' dom' codom'), (eq_binder_annot na na'), Σ ;;; Γ ⊢ dom = dom' & Σ ;;; Γ ,, vass na dom ⊢ codom ≤[pb] codom']. @@ -685,10 +685,10 @@ Section ConvCongruences. Lemma ws_cumul_pb_Prod_r_inv {pb Γ na dom codom T} : Σ ;;; Γ ⊢ T ≤[pb] tProd na dom codom -> - ∑ na' dom' codom', + ∑ na' dom' codom', [× Σ ;;; Γ ⊢ T ⇝ (tProd na' dom' codom'), - eq_binder_annot na na', - Σ ;;; Γ ⊢ dom' = dom & + eq_binder_annot na na', + Σ ;;; Γ ⊢ dom' = dom & Σ ;;; Γ ,, vass na dom ⊢ codom' ≤[pb] codom]. Proof using wfΣ. intros H. @@ -712,7 +712,7 @@ Section ConvCongruences. * transitivity codom'; pcuic. eapply ws_cumul_pb_compare; eauto with fvs. Qed. - + Ltac splits := repeat split. Lemma ws_cumul_pb_Prod_Prod_inv {pb Γ na na' dom dom' codom codom'} : @@ -755,14 +755,14 @@ End ConvCongruences. Notation red_terms Σ Γ := (All2 (closed_red Σ Γ)). -Lemma red_terms_ws_cumul_pb_terms {cf} {Σ} {wfΣ : wf Σ} {Γ u u'} : +Lemma red_terms_ws_cumul_pb_terms {cf} {Σ} {wfΣ : wf Σ} {Γ u u'} : red_terms Σ Γ u u' -> ws_cumul_pb_terms Σ Γ u u'. Proof. move=> Hu; eapply All2_impl; eauto. intros. now eapply red_ws_cumul_pb. Qed. -Lemma eq_terms_ws_cumul_pb_terms {cf} {Σ} {wfΣ : wf Σ} Γ u u' : +Lemma eq_terms_ws_cumul_pb_terms {cf} {Σ} {wfΣ : wf Σ} Γ u u' : is_closed_context Γ -> forallb (is_open_term Γ) u -> forallb (is_open_term Γ) u' -> @@ -773,8 +773,8 @@ Proof. Qed. Lemma closed_red_letin {Σ Γ na d0 d1 t0 t1 b0 b1} : - Σ ;;; Γ ⊢ d0 ⇝ d1 -> - Σ ;;; Γ ⊢ t0 ⇝ t1 -> + Σ ;;; Γ ⊢ d0 ⇝ d1 -> + Σ ;;; Γ ⊢ t0 ⇝ t1 -> Σ ;;; Γ ,, vdef na d1 t1 ⊢ b0 ⇝ b1 -> Σ ;;; Γ ⊢ tLetIn na d0 t0 b0 ⇝ tLetIn na d1 t1 b1. Proof. @@ -815,7 +815,7 @@ Lemma closed_red_prod {Σ Γ na A B A' B'} : Proof. intros h1 h2. eapply into_closed_red; fvs. - eapply red_prod; auto. + eapply red_prod; auto. * apply h1. * apply h2. Qed. @@ -905,7 +905,7 @@ Section Inversions. induction H; simplify *. - depind r. solve_discr. - reflexivity. - - rewrite IHclos_refl_trans2; eauto with fvs. + - rewrite IHclos_refl_trans2; eauto with fvs. Qed. Lemma eq_term_upto_univ_conv_arity_l : @@ -942,7 +942,7 @@ Section Inversions. * len. now setoid_rewrite shiftnP_add in p4. * len. now setoid_rewrite shiftnP_add in p1. Qed. - + Lemma eq_term_upto_univ_conv_arity_r : forall Re Rle Γ u v, isArity u -> @@ -978,7 +978,7 @@ Section Inversions. * len. now setoid_rewrite shiftnP_add in p4. * len. now setoid_rewrite shiftnP_add in p1. Qed. - + Lemma isArity_subst : forall u v k, isArity u -> @@ -1057,7 +1057,7 @@ Section Inversions. now eapply red1_red. + assumption. Qed. - + Hint Constructors All_decls : core. Lemma ws_cumul_pb_red_r_inv {Γ T} U {U'} {pb} : @@ -1140,7 +1140,7 @@ Section Inversions. Lemma compare_term_mkApps_r_inv {pb} {u : term} {l : list term} {t : term} : compare_term pb Σ Σ t (mkApps u l) -> ∑ (u' : term) (l' : list term), - [× eq_term_upto_univ_napp Σ (eq_universe Σ) (compare_universe pb Σ) #|l| u' u, + [× eq_term_upto_univ_napp Σ (eq_universe Σ) (compare_universe pb Σ) #|l| u' u, All2 (eq_term Σ Σ) l' l & t = mkApps u' l']. Proof using wfΣ. destruct pb => /= => /eq_term_upto_univ_mkApps_r_inv; firstorder. @@ -1170,25 +1170,25 @@ Section Inversions. constructor; eauto with fvs. Qed. - Lemma closed_red_terms_open_left {Γ l l'}: + Lemma closed_red_terms_open_left {Γ l l'}: All2 (closed_red Σ Γ) l l' -> All (is_open_term Γ) l. Proof using Type. solve_all; eauto with fvs. Qed. - - Lemma closed_red_terms_open_right {Γ l l'}: + + Lemma closed_red_terms_open_right {Γ l l'}: All2 (closed_red Σ Γ) l l' -> All (is_open_term Γ) l'. Proof using wfΣ. solve_all; eauto with fvs. Qed. Hint Resolve closed_red_terms_open_left closed_red_terms_open_right : fvs. - Lemma ws_cumul_pb_terms_open_terms_left {Γ s s'} : + Lemma ws_cumul_pb_terms_open_terms_left {Γ s s'} : ws_cumul_pb_terms Σ Γ s s' -> forallb (is_open_term Γ) s. Proof using wfΣ. solve_all; eauto with fvs. Qed. - Lemma ws_cumul_pb_terms_open_terms_right {Γ s s'} : + Lemma ws_cumul_pb_terms_open_terms_right {Γ s s'} : ws_cumul_pb_terms Σ Γ s s' -> forallb (is_open_term Γ) s'. Proof using wfΣ. @@ -1217,7 +1217,7 @@ Section Inversions. now rewrite PCUICOnFreeVars.on_free_vars_mkApps /= in redv. } solve_all; eauto with fvs. constructor; eauto with fvs. - * eapply All2_impl. + * eapply All2_impl. + eapply All2_sym; tea. + cbn. eauto with pcuic. Qed. @@ -1349,7 +1349,7 @@ Definition ws_cumul_pb_predicate {cf} Σ Γ p p' := R_universe_instance (eq_universe Σ) (puinst p) (puinst p'), eq_context_gen eq eq (pcontext p) (pcontext p') & Σ ;;; Γ ,,, inst_case_predicate_context p ⊢ preturn p = preturn p']. - + Definition ws_cumul_pb_brs {cf} Σ Γ p := All2 (fun br br' => eq_context_gen eq eq (bcontext br) (bcontext br') × @@ -1393,7 +1393,7 @@ Section Inversions. econstructor; tea; cbn; eauto with fvs. eapply red1_red. constructor; auto. Qed. - + Lemma ws_cumul_pb_mkApps {pb Γ hd args hd' args'} : Σ;;; Γ ⊢ hd ≤[pb] hd' -> ws_cumul_pb_terms Σ Γ args args' -> @@ -1412,8 +1412,8 @@ Section Inversions. Notation "Σ ;;; Γ ⊢ t ⇝1 u" := (closed_red1 Σ Γ t u) (at level 50, Γ, t, u at next level, format "Σ ;;; Γ ⊢ t ⇝1 u"). - Lemma closed_red1_mkApps_left {Γ} {t u ts} : - Σ ;;; Γ ⊢ t ⇝1 u -> + Lemma closed_red1_mkApps_left {Γ} {t u ts} : + Σ ;;; Γ ⊢ t ⇝1 u -> forallb (is_open_term Γ) ts -> Σ ;;; Γ ⊢ mkApps t ts ⇝1 mkApps u ts. Proof using Type. @@ -1517,7 +1517,7 @@ Section ConvRedConv. eapply ws_cumul_pb_ws_cumul_ctx; tea. eapply red_ws_cumul_pb_right; tea. Qed. - + Lemma Prod_conv_cum_inv {Γ leq na1 na2 A1 A2 B1 B2} : sq_ws_cumul_pb leq Σ Γ (tProd na1 A1 B1) (tProd na2 A2 B2) -> eq_binder_annot na1 na2 /\ ∥ Σ ;;; Γ ⊢ A1 = A2 ∥ /\ @@ -1530,7 +1530,7 @@ Section ConvRedConv. - apply ws_cumul_ctx_pb_refl; eauto with fvs. - constructor; auto. Qed. - + Lemma conv_cum_conv_ctx leq pb Γ Γ' T U : sq_ws_cumul_pb leq Σ Γ T U -> Σ ⊢ Γ' ≤[pb] Γ -> @@ -1539,7 +1539,7 @@ Section ConvRedConv. intros [] h. now eapply ws_cumul_pb_ws_cumul_ctx in X; tea. Qed. - + Lemma conv_cum_red leq Γ t1 t2 t1' t2' : Σ ;;; Γ ⊢ t1' ⇝ t1 -> Σ ;;; Γ ⊢ t2' ⇝ t2 -> @@ -1577,7 +1577,7 @@ Section ConvRedConv. - transitivity t2 => //. now apply red_ws_cumul_pb. Qed. - + Lemma conv_cum_red_conv_inv pb Γ Γ' t1 t2 t1' t2' : Σ ⊢ Γ = Γ' -> Σ ;;; Γ ⊢ t1 ⇝ t1' -> @@ -1590,7 +1590,7 @@ Section ConvRedConv. transitivity t2 => //. eapply ws_cumul_pb_ws_cumul_ctx in r2; tea. Qed. - + Lemma conv_cum_red_iff leq Γ t1 t2 t1' t2' : Σ ;;; Γ ⊢ t1' ⇝ t1 -> Σ ;;; Γ ⊢ t2' ⇝ t2 -> @@ -1656,7 +1656,7 @@ Section ConvRedConv. - eapply ws_cumul_pb_App_l; tea; eauto with fvs. - apply ws_cumul_pb_App_r; tea. eauto with fvs. Qed. - + #[global] Instance all_eq_term_refl : Reflexive (All2 (eq_term_upto_univ Σ.1 (eq_universe Σ) (eq_universe Σ))). Proof using Type. @@ -1668,15 +1668,15 @@ Section ConvRedConv. puinst := puinst; pcontext := p.(pcontext); preturn := p.(preturn) |}. - - Definition set_preturn_two {p} pret pret' : set_preturn (set_preturn p pret') pret = set_preturn p pret := + + Definition set_preturn_two {p} pret pret' : set_preturn (set_preturn p pret') pret = set_preturn p pret := eq_refl. (*Lemma conv_context_red_context Γ Γ' Δ Δ' : ws_cumul_ctx_pb false Σ (Γ ,,, Δ) (Γ' ,,, Δ') -> #|Γ| = #|Γ'| -> - ∑ Δ1 Δ1', red_ctx_rel Σ Γ Δ Δ1 × red_ctx_rel Σ Γ' Δ' Δ1' × + ∑ Δ1 Δ1', red_ctx_rel Σ Γ Δ Δ1 × red_ctx_rel Σ Γ' Δ' Δ1' × eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Δ1 Δ1'. Proof. intros. @@ -1767,7 +1767,7 @@ Section ConvRedConv. destruct r. now transitivity #|y|. Qed. - + Definition is_open_case (Γ : context) p c brs := [&& forallb (is_open_term Γ) p.(pparams), on_free_vars (shiftnP #|p.(pcontext)| (shiftnP #|Γ| xpred0)) p.(preturn), @@ -1780,7 +1780,7 @@ Section ConvRedConv. rewrite /is_open_case. now repeat bool_congr. Qed. - Lemma is_open_case_set_pparams Γ p c brs pars' : + Lemma is_open_case_set_pparams Γ p c brs pars' : forallb (is_open_term Γ) pars' -> #|pars'| = #|p.(pparams)| -> is_open_case Γ p c brs -> @@ -1793,7 +1793,7 @@ Section ConvRedConv. rewrite andb_true_r //. Qed. - Lemma is_open_case_set_preturn Γ p c brs pret' : + Lemma is_open_case_set_preturn Γ p c brs pret' : is_open_term (Γ ,,, inst_case_predicate_context p) pret' -> is_open_case Γ p c brs -> is_open_case Γ (set_preturn p pret') c brs. @@ -1898,7 +1898,7 @@ Section ConvRedConv. move/and5P: oncase => [] _ _ _ -> /=. now rewrite (All2_length cpars). Qed. - + Lemma ws_cumul_pb_Case_c : forall Γ indn p brs u v, is_open_predicate Γ p -> @@ -1950,8 +1950,8 @@ Section ConvRedConv. is_open_term Γ c -> is_open_brs Γ p brs -> is_open_brs Γ p brs' -> - OnOne2 (fun u v => - eq_context_gen eq eq u.(bcontext) v.(bcontext) × + OnOne2 (fun u v => + eq_context_gen eq eq u.(bcontext) v.(bcontext) × Σ ;;; (Γ ,,, inst_case_branch_context p u) ⊢ u.(bbody) = v.(bbody)) brs brs' -> Σ ;;; Γ ⊢ tCase indn p c brs = tCase indn p c brs'. Proof using wfΣ. @@ -1995,7 +1995,7 @@ Section ConvRedConv. Qed. - Lemma is_open_brs_OnOne2 Γ p x y : + Lemma is_open_brs_OnOne2 Γ p x y : is_open_brs Γ p x -> OnOne2 (fun u v : branch term => eq_context_gen eq eq (bcontext u) (bcontext v) * @@ -2027,7 +2027,7 @@ Section ConvRedConv. Σ ;;; Γ ⊢ tCase ci p c brs = tCase ci p c brs'. Proof using wfΣ. intros onΓ onp onc onbrs onbrs' h. - eapply (All2_many_OnOne2_pres _ (fun br => + eapply (All2_many_OnOne2_pres _ (fun br => is_open_term (Γ ,,, inst_case_branch_context p br) br.(bbody))) in h. 2:{ intros x y [eq cv]. split; [eapply ws_cumul_pb_is_open_term_left|eapply ws_cumul_pb_is_open_term_right]; tea. @@ -2059,7 +2059,7 @@ Section ConvRedConv. ws_cumul_pb_brs Σ Γ p brs brs' -> Σ ;;; Γ ⊢ tCase ci p c brs = tCase ci p' c' brs'. Proof using wfΣ. - intros onc0. generalize onc0. + intros onc0. generalize onc0. rewrite !is_open_case_split => /and3P[onp onc onbrs] /and3P[onp' onc' onbrs']. move=> cvp cvc. assert (clΓ := ws_cumul_pb_is_closed_context cvc). @@ -2076,8 +2076,8 @@ Section ConvRedConv. rewrite is_open_case_split onp onc' /=. now rewrite (All2_length onpars). Qed. - - Definition fix_or_cofix b mfix idx := + + Definition fix_or_cofix b mfix idx := (if b then tFix else tCoFix) mfix idx. Lemma eq_term_fix_or_cofix b mfix idx mfix' : @@ -2096,7 +2096,7 @@ Section ConvRedConv. Notation is_open_mfix Γ mfix := (forallb (is_open_def Γ #|mfix|) mfix). - Lemma is_open_fix_or_cofix {b} {Γ : context} {mfix idx} : + Lemma is_open_fix_or_cofix {b} {Γ : context} {mfix idx} : is_open_term Γ (fix_or_cofix b mfix idx) = is_open_mfix Γ mfix. Proof using Type. by case: b. Qed. @@ -2134,7 +2134,7 @@ Section ConvRedConv. destruct b; constructor; apply OnOne2_app; constructor; simpl; intuition eauto. Qed. - + Lemma ws_cumul_pb_fix_types {b Γ mfix mfix' idx} : is_closed_context Γ -> is_open_mfix Γ mfix -> @@ -2161,7 +2161,7 @@ Section ConvRedConv. 1-2:rewrite is_open_fix_or_cofix //. cbn; reflexivity. - etransitivity. - + eapply IHh. + + eapply IHh. + destruct r as [hlen [onone [ay az]]]. eapply ws_cumul_pb_fix_one_type; tea; solve_all. all:now rewrite -?hlen -(rtrans_clos_length h). @@ -2174,7 +2174,7 @@ Section ConvRedConv. Proof using Type. destruct b; apply red_fix_body || apply red_cofix_body. Qed. - + Lemma ws_cumul_pb_fix_one_body {b Γ mfix mfix' idx} : is_closed_context Γ -> is_open_mfix Γ mfix -> @@ -2220,7 +2220,7 @@ Section ConvRedConv. { eapply red_fix_or_cofix_body. rewrite H0. eapply All2_app; try reflexivity. { eapply All2_refl; intuition auto. } - constructor. + constructor. - cbn. intuition auto. rewrite -H0. eapply red_eq_context_upto_names; tea. @@ -2235,7 +2235,7 @@ Section ConvRedConv. eapply All2_refl; intuition auto; reflexivity. } Qed. - Lemma is_open_fix_onone2 {Γ Δ mfix mfix'} : + Lemma is_open_fix_onone2 {Γ Δ mfix mfix'} : OnOne2 (fun u v : def term => (dtype u = dtype v) * @@ -2323,13 +2323,13 @@ Section ConvRedConv. apply thm. Qed. - Lemma ws_cumul_pb_fix_or_cofix {b Γ mfix mfix' idx} : + Lemma ws_cumul_pb_fix_or_cofix {b Γ mfix mfix' idx} : is_closed_context Γ -> All2 (fun u v => Σ;;; Γ ⊢ dtype u = dtype v × Σ;;; Γ ,,, fix_context mfix ⊢ dbody u = dbody v × (rarg u = rarg v) * - (eq_binder_annot (dname u) (dname v))) + (eq_binder_annot (dname u) (dname v))) mfix mfix' -> Σ ;;; Γ ⊢ fix_or_cofix b mfix idx = fix_or_cofix b mfix' idx. Proof using wfΣ. @@ -2356,7 +2356,7 @@ Section ConvRedConv. Σ;;; Γ ,,, fix_context mfix ⊢ dbody u = dbody v × rarg u = rarg v × (eq_binder_annot (dname u) (dname v)) - ) mfix mfix'' + ) mfix mfix'' ). { set (P1 := fun u v => Σ ;;; Γ ⊢ u = v). set (P2 := fun u v => Σ ;;; Γ ,,, fix_context mfix ⊢ u = v). @@ -2387,7 +2387,7 @@ Section ConvRedConv. + constructor. 2: assumption. simpl. intuition eauto. + constructor. 2: assumption. - intuition eauto. + intuition eauto. } destruct h' as [mfix'' [h1 h2]]. assert (is_open_mfix Γ mfix''). @@ -2404,28 +2404,28 @@ Section ConvRedConv. - eapply ws_cumul_pb_fix_types. all: assumption. Qed. - Lemma ws_cumul_pb_Fix {Γ mfix mfix' idx} : + Lemma ws_cumul_pb_Fix {Γ mfix mfix' idx} : is_closed_context Γ -> All2 (fun u v => Σ;;; Γ ⊢ dtype u = dtype v × Σ;;; Γ ,,, fix_context mfix ⊢ dbody u = dbody v × (rarg u = rarg v) * - (eq_binder_annot (dname u) (dname v))) + (eq_binder_annot (dname u) (dname v))) mfix mfix' -> Σ ;;; Γ ⊢ tFix mfix idx = tFix mfix' idx. Proof using wfΣ. eapply (ws_cumul_pb_fix_or_cofix (b:=true)). Qed. - Lemma ws_cumul_pb_CoFix {Γ mfix mfix' idx} : + Lemma ws_cumul_pb_CoFix {Γ mfix mfix' idx} : is_closed_context Γ -> All2 (fun u v => Σ;;; Γ ⊢ dtype u = dtype v × Σ;;; Γ ,,, fix_context mfix ⊢ dbody u = dbody v × (rarg u = rarg v) * - (eq_binder_annot (dname u) (dname v))) + (eq_binder_annot (dname u) (dname v))) mfix mfix' -> Σ ;;; Γ ⊢ tCoFix mfix idx = tCoFix mfix' idx. Proof using wfΣ. eapply (ws_cumul_pb_fix_or_cofix (b:=false)). Qed. - + Lemma ws_cumul_pb_eq_le_gen {pb Γ T U} : Σ ;;; Γ ⊢ T = U -> Σ ;;; Γ ⊢ T ≤[pb] U. @@ -2451,7 +2451,7 @@ Section ConvRedConv. all:rewrite on_fvs_lambda; eauto with fvs. Qed. - Lemma ws_cumul_pb_Lambda_r {pb Γ na A b b'} : + Lemma ws_cumul_pb_Lambda_r {pb Γ na A b b'} : Σ ;;; Γ,, vass na A ⊢ b ≤[pb] b' -> Σ ;;; Γ ⊢ tLambda na A b ≤[pb] tLambda na A b'. Proof using wfΣ. @@ -2480,9 +2480,9 @@ Section ConvRedConv. { clear -h. induction h. - destruct pb; eapply cumul_refl; constructor. - all: try reflexivity; auto. + all: try reflexivity; auto. - destruct pb; - eapply cumul_red_l; tea; pcuic. + eapply cumul_red_l; tea; pcuic. - destruct pb; eapply cumul_red_r ; pcuic. } { rewrite on_fvs_letin onty ont //. } @@ -2501,7 +2501,7 @@ Section ConvRedConv. - simpl. cbn. eapply ih. eapply ws_cumul_pb_Lambda_r. assumption. Qed. - + Lemma ws_cumul_pb_it_mkProd_or_LetIn_codom {Δ Γ B B' pb} : Σ ;;; (Δ ,,, Γ) ⊢ B ≤[pb] B' -> Σ ;;; Δ ⊢ it_mkProd_or_LetIn Γ B ≤[pb] it_mkProd_or_LetIn Γ B'. @@ -2520,7 +2520,7 @@ Section ConvRedConv. Lemma ws_cumul_pb_mkApps_weak : forall Γ u1 u2 l, - forallb (is_open_term Γ) l -> + forallb (is_open_term Γ) l -> Σ ;;; Γ ⊢ u1 = u2 -> Σ ;;; Γ ⊢ mkApps u1 l = mkApps u2 l. Proof using wfΣ. @@ -2633,7 +2633,7 @@ Section ConvRedConv. rewrite on_fvs_lambda in onl. move: onl => /=/andP [] onA1 onb1. eapply clos_rt_rt1n_iff in ont. depind ont. - - eexists _, _. split => //. + - eexists _, _. split => //. eapply closed_red_refl; eauto with fvs. - depelim r; solve_discr; specialize (IHont _ _ _ _ onΓ eq_refl byfvs). + forward IHont by tas. @@ -2728,7 +2728,7 @@ Section ConvSubst. rewrite (closedn_on_free_vars t0) //. Qed. Hint Resolve subslet_open : fvs. - + Lemma untyped_closed_red_subst {Γ Δ Γ' s M N} : untyped_subslet Γ s Δ -> forallb (is_open_term Γ) s -> @@ -2814,7 +2814,7 @@ Section ConvSubst. Derive Signature for untyped_subslet. - Lemma ws_cumul_pb_substs_red {Γ Δ s s'} : + Lemma ws_cumul_pb_substs_red {Γ Δ s s'} : ws_cumul_pb_terms Σ Γ s s' -> untyped_subslet Γ s Δ -> ∑ s0 s'0, [× All2 (closed_red Σ Γ) s s0, All2 (closed_red Σ Γ) s' s'0 & All2 (eq_term Σ Σ) s0 s'0]. @@ -2832,7 +2832,7 @@ Section ConvSubst. Qed. Lemma All2_fold_fold_context_k P (f g : nat -> term -> term) ctx ctx' : - All2_fold (fun Γ Γ' d d' => P (fold_context_k f Γ) (fold_context_k g Γ') + All2_fold (fun Γ Γ' d d' => P (fold_context_k f Γ) (fold_context_k g Γ') (map_decl (f #|Γ|) d) (map_decl (g #|Γ'|) d')) ctx ctx' -> All2_fold P (fold_context_k f ctx) (fold_context_k g ctx'). Proof using Type. @@ -2844,7 +2844,7 @@ Section ConvSubst. now rewrite -(length_of H). Qed. - Lemma All_decls_alpha_pb_impl le P Q d d' : + Lemma All_decls_alpha_pb_impl le P Q d d' : All_decls_alpha_pb le P d d' -> (forall le x y, P le x y -> Q le x y) -> All_decls_alpha_pb le Q d d'. @@ -2852,7 +2852,7 @@ Section ConvSubst. intros [] H; constructor; auto. Qed. - Lemma All_decls_alpha_pb_map le P f g d d' : + Lemma All_decls_alpha_pb_map le P f g d d' : All_decls_alpha_pb le (fun le x y => P le (f x) (g y)) d d' -> All_decls_alpha_pb le P (map_decl f d) (map_decl g d'). Proof using Type. @@ -2869,8 +2869,8 @@ Section ConvSubst. - move/andP: ht => /= [] pb pty; eauto. - move/andP: ht => /= [] pb pty; eauto. Qed. - - Lemma substitution_ws_cumul_ctx_pb_red_subst {Γ Δ Γ' s s'} : + + Lemma substitution_ws_cumul_ctx_pb_red_subst {Γ Δ Γ' s s'} : is_closed_context (Γ ,,, Δ ,,, Γ') -> All2 (closed_red Σ Γ) s s' -> untyped_subslet Γ s Δ -> @@ -2889,7 +2889,7 @@ Section ConvSubst. move: H; rewrite /= on_free_vars_ctx_snoc => /andP[] // iscl wsdecl. eapply test_decl_conv_decls_map; tea. intros x hx. - eapply PCUICCumulativity.red_conv. + eapply PCUICCumulativity.red_conv. rewrite - !/(subst_context _ _ _) Nat.add_0_r. eapply red_red; tea. { erewrite on_free_vars_ctx_on_ctx_free_vars; tea. } @@ -2898,14 +2898,14 @@ Section ConvSubst. eauto with fvs. } Qed. - Lemma subst_context_app0 s Γ Γ' : - subst_context s 0 Γ ,,, subst_context s #|Γ| Γ' = + Lemma subst_context_app0 s Γ Γ' : + subst_context s 0 Γ ,,, subst_context s #|Γ| Γ' = subst_context s 0 (Γ ,,, Γ'). Proof using Type. now rewrite -(Nat.add_0_r #|Γ|) subst_context_app. Qed. - Lemma eq_context_upto_ws_cumul_ctx_pb {pb Γ Γ'} : + Lemma eq_context_upto_ws_cumul_ctx_pb {pb Γ Γ'} : is_closed_context Γ -> is_closed_context Γ' -> eq_context_upto Σ (eq_universe Σ) (compare_universe pb Σ) Γ Γ' -> @@ -2918,7 +2918,7 @@ Section ConvSubst. { now eapply eq_context_upto_univ_conv_context. } Qed. - Lemma substitution_ws_cumul_ctx_pb {Γ Δ Δ' Γ' s s'} : + Lemma substitution_ws_cumul_ctx_pb {Γ Δ Δ' Γ' s s'} : untyped_subslet Γ s Δ -> untyped_subslet Γ s' Δ' -> ws_cumul_pb_terms Σ Γ s s' -> @@ -2942,7 +2942,7 @@ Section ConvSubst. eapply All2_symP; tc. assumption. Qed. - Lemma untyped_substitution_ws_cumul_pb_subst_conv {Γ Δ Δ' Γ' s s' b} : + Lemma untyped_substitution_ws_cumul_pb_subst_conv {Γ Δ Δ' Γ' s s' b} : ws_cumul_pb_terms Σ Γ s s' -> is_closed_context (Γ ,,, Δ ,,, Γ') -> is_closed_context (Γ ,,, Δ' ,,, Γ') -> @@ -3102,10 +3102,10 @@ Qed. Definition ws_cumul_ctx_pb_rel {cf} pb Σ Γ Δ Δ' := is_closed_context Γ × - All2_fold (fun Γ' _ => All_decls_alpha_pb pb (fun pb x y => Σ ;;; Γ ,,, Γ' ⊢ x ≤[pb] y)) Δ Δ'. + All2_fold (fun Γ' _ => All_decls_alpha_pb pb (fun pb x y => Σ ;;; Γ ,,, Γ' ⊢ x ≤[pb] y)) Δ Δ'. Lemma ws_cumul_ctx_pb_rel_app {cf} {Σ} {wfΣ : wf Σ} {pb Γ Δ Δ'} : - ws_cumul_ctx_pb_rel pb Σ Γ Δ Δ' <~> + ws_cumul_ctx_pb_rel pb Σ Γ Δ Δ' <~> ws_cumul_ctx_pb pb Σ (Γ ,,, Δ) (Γ ,,, Δ'). Proof. split; intros h. @@ -3131,7 +3131,7 @@ Proof. induction Δ as [|d Δ] in wf |- *. - constructor. - simpl. depelim wf. - * cbn; constructor. + * cbn; constructor. + apply IHΔ => //. + destruct d as [na [b|] ty]; constructor; cbn in *; auto; try congruence. destruct l as [s Hs]. @@ -3141,7 +3141,7 @@ Proof. eapply subject_closed in Hs; rewrite is_open_term_closed in Hs. now rewrite on_free_vars_subst_instance in Hs. } destruct pb; apply eq_term_upto_univ_subst_instance; try typeclasses eauto; auto. - * cbn; constructor. + * cbn; constructor. + apply IHΔ => //. + destruct d as [na [b'|] ty]; constructor; cbn in *; auto; try congruence; noconf H. { destruct l as [s Hs]. @@ -3160,13 +3160,13 @@ Proof. destruct pb; apply eq_term_upto_univ_subst_instance; try typeclasses eauto; auto. } Qed. -Lemma is_closed_context_subst_instance Γ Δ u : +Lemma is_closed_context_subst_instance Γ Δ u : is_closed_context (Γ ,,, Δ @[u]) = is_closed_context (Γ ,,, Δ). Proof. rewrite !on_free_vars_ctx_app. eauto with fvs. Qed. -Lemma is_open_term_subst_instance Γ Δ t u u' : +Lemma is_open_term_subst_instance Γ Δ t u u' : is_open_term (Γ ,,, Δ @[u]) t@[u'] = is_open_term (Γ ,,, Δ) t. Proof. rewrite !app_context_length; len. eauto with fvs. @@ -3195,17 +3195,17 @@ Proof. - simpl. destruct d as [na [b|] ty] => /=. * move: equ; rewrite /= on_free_vars_ctx_snoc => /= /andP[] clΔ /andP[] /= onb onty. - rewrite !subst_instance_cons; constructor; eauto. simpl. constructor. + rewrite !subst_instance_cons; constructor; eauto. simpl. constructor. + reflexivity. + constructor; cbn. 4:eapply eq_term_upto_univ_subst_instance; try typeclasses eauto; auto. all:eauto with fvs. - + constructor. + + constructor. 4:cbn; eapply eq_term_compare_term; eapply eq_term_upto_univ_subst_instance; try typeclasses eauto; auto. all:eauto with fvs. * move: equ; rewrite /= on_free_vars_ctx_snoc => /= /andP[] clΔ /andP[] /= onb onty. - rewrite !subst_instance_cons; constructor; eauto. simpl. constructor. + rewrite !subst_instance_cons; constructor; eauto. simpl. constructor. + reflexivity. + cbn. constructor; auto. 4:cbn; eapply eq_term_compare_term; @@ -3428,7 +3428,7 @@ Section ConvTerms. intros x y eqxy. eapply substitution_ws_cumul_pb_subst_conv; eauto with fvs. Qed. - + End ConvTerms. Section CumulSubst. @@ -3473,7 +3473,7 @@ Section CumulSubst. relativize #|Δ'0 ++ Γ''|; [apply (substitution_ws_cumul_pb_subst_conv (pb:=pb') hs hs' eqs)|] => //. 1:rewrite app_context_assoc //. len. - Qed. + Qed. Lemma weaken_ws_cumul_ctx_pb_rel {pb Γ Γ' Δ Δ'} : is_closed_context Γ -> @@ -3482,7 +3482,7 @@ Section CumulSubst. Proof using wfΣ. intros wf [cl eq]. split. - { rewrite on_free_vars_ctx_app wf /=. + { rewrite on_free_vars_ctx_app wf /=. eapply on_free_vars_ctx_impl; tea => //. congruence. } induction eq. @@ -3582,20 +3582,20 @@ Section MoreCongruenceLemmas. Context {cf:checker_flags} (Σ : global_env_ext) (wfΣ : wf Σ). - Lemma red_terms_evar Γ args args0 ev : + Lemma red_terms_evar Γ args args0 ev : red_terms Σ Γ args args0 -> red Σ Γ (tEvar ev args) (tEvar ev args0). - intros Hargs. eapply red_evar. - eapply All2_impl. 1: tea. intros. destruct X; eauto. - Defined. + intros Hargs. eapply red_evar. + eapply All2_impl. 1: tea. intros. destruct X; eauto. + Defined. Lemma ws_cumul_pb_Evar {pb Γ ev args args'} : ws_cumul_pb_terms Σ Γ args args' -> is_closed_context Γ -> Σ;;; Γ ⊢ tEvar ev args ≤[pb] tEvar ev args'. Proof. - intros Hargsargs' HΓ. pose proof (Hargs := ws_cumul_pb_terms_open_terms_left Hargsargs'). pose proof (Hargs' := ws_cumul_pb_terms_open_terms_right Hargsargs'). - apply ws_cumul_pb_terms_alt in Hargsargs'. destruct Hargsargs' as [args0 [args0' [Hargs0 Hargs0' Hargs0args0']]]. - pose proof (Hargs0_c := closed_red_terms_open_right Hargs0). - pose proof (Hargs0'_c := closed_red_terms_open_right Hargs0'). + intros Hargsargs' HΓ. pose proof (Hargs := ws_cumul_pb_terms_open_terms_left Hargsargs'). pose proof (Hargs' := ws_cumul_pb_terms_open_terms_right Hargsargs'). + apply ws_cumul_pb_terms_alt in Hargsargs'. destruct Hargsargs' as [args0 [args0' [Hargs0 Hargs0' Hargs0args0']]]. + pose proof (Hargs0_c := closed_red_terms_open_right Hargs0). + pose proof (Hargs0'_c := closed_red_terms_open_right Hargs0'). assert (Σ;;; Γ ⊢ tEvar ev args0 ≤[pb] tEvar ev args0'). { econstructor; eauto; cbn. 3: econstructor; eauto. all: eapply All_forallb; eauto. } @@ -3604,7 +3604,7 @@ Section MoreCongruenceLemmas. eapply red_ws_cumul_pb_left in X. 2: split; eauto; cbn; eauto. eapply red_ws_cumul_pb_right in X. 2: split; eauto; cbn; eauto. exact X. - Defined. + Defined. Lemma ws_cumul_pb_Ind {pb Γ ind ui ui' l l'} : [× R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (IndRef ind) #|l| ui ui', @@ -3612,23 +3612,23 @@ Section MoreCongruenceLemmas. Σ ;;; Γ ⊢ mkApps (tInd ind ui) l ≤[pb] mkApps (tInd ind ui') l'. intros [Rglob Rclosed Hll']. apply ws_cumul_pb_terms_alt in Hll'. destruct Hll' as [l0 [l0' [Hl0 Hl0' Hl0l0']]]. assert (Σ ;;; Γ ⊢ mkApps (tInd ind ui) l0 ≤[pb] mkApps (tInd ind ui') l0'). - { econstructor 1; eauto. - - cbn. clear -cf wfΣ Hl0. rewrite on_free_vars_mkApps; cbn. apply All_forallb. induction Hl0; eauto; intros. cbn in *. econstructor; eauto. + { econstructor 1; eauto. + - cbn. clear -cf wfΣ Hl0. rewrite on_free_vars_mkApps; cbn. apply All_forallb. induction Hl0; eauto; intros. cbn in *. econstructor; eauto. destruct r; eapply red_is_open_term; eauto. - - cbn. clear -cf wfΣ Hl0'. rewrite on_free_vars_mkApps; cbn. apply All_forallb. induction Hl0'; eauto; intros. cbn in *. econstructor; eauto. + - cbn. clear -cf wfΣ Hl0'. rewrite on_free_vars_mkApps; cbn. apply All_forallb. induction Hl0'; eauto; intros. cbn in *. econstructor; eauto. destruct r; eapply red_is_open_term; eauto. - - apply All2_length in Hl0. rewrite Hl0 in Rglob. clear Hl0 Hl0'. - apply eq_term_upto_univ_napp_mkApps; eauto. - econstructor; eauto. assert (#|l0| + 0 = #|l0|) by lia. rewrite H. destruct pb; eauto. - } - apply red_terms_ws_cumul_pb_terms in Hl0, Hl0'. - etransitivity. - - eapply ws_cumul_pb_mkApps. - * refine (ws_cumul_pb_refl' (exist Γ Rclosed) (exist (tInd ind ui) _)); eauto. + - apply All2_length in Hl0. rewrite Hl0 in Rglob. clear Hl0 Hl0'. + apply eq_term_upto_univ_napp_mkApps; eauto. + econstructor; eauto. assert (#|l0| + 0 = #|l0|) by lia. rewrite H. destruct pb; eauto. + } + apply red_terms_ws_cumul_pb_terms in Hl0, Hl0'. + etransitivity. + - eapply ws_cumul_pb_mkApps. + * refine (ws_cumul_pb_refl' (exist Γ Rclosed) (exist (tInd ind ui) _)); eauto. * eassumption. - cbn. etransitivity; try apply X. eapply ws_cumul_pb_mkApps. - * refine (ws_cumul_pb_refl' (exist Γ Rclosed) (exist (tInd ind ui') _)); eauto. + * refine (ws_cumul_pb_refl' (exist Γ Rclosed) (exist (tInd ind ui') _)); eauto. * symmetry. eassumption. Defined. @@ -3638,23 +3638,23 @@ Section MoreCongruenceLemmas. Σ ;;; Γ ⊢ mkApps (tConstruct i k ui) l ≤[pb] mkApps (tConstruct i k ui') l'. intros [Rglob Rclosed Hll']. apply ws_cumul_pb_terms_alt in Hll'. destruct Hll' as [l0 [l0' [Hl0 Hl0' Hl0l0']]]. assert (Σ ;;; Γ ⊢ mkApps (tConstruct i k ui) l0 ≤[pb] mkApps (tConstruct i k ui') l0'). - { econstructor 1; eauto. - - cbn. clear -cf wfΣ Hl0. rewrite on_free_vars_mkApps; cbn. apply All_forallb. induction Hl0; eauto; intros. cbn in *. econstructor; eauto. + { econstructor 1; eauto. + - cbn. clear -cf wfΣ Hl0. rewrite on_free_vars_mkApps; cbn. apply All_forallb. induction Hl0; eauto; intros. cbn in *. econstructor; eauto. destruct r; eapply red_is_open_term; eauto. - - cbn. clear -cf wfΣ Hl0'. rewrite on_free_vars_mkApps; cbn. apply All_forallb. induction Hl0'; eauto; intros. cbn in *. econstructor; eauto. + - cbn. clear -cf wfΣ Hl0'. rewrite on_free_vars_mkApps; cbn. apply All_forallb. induction Hl0'; eauto; intros. cbn in *. econstructor; eauto. destruct r; eapply red_is_open_term; eauto. - - apply All2_length in Hl0. rewrite Hl0 in Rglob. clear Hl0 Hl0'. - apply eq_term_upto_univ_napp_mkApps; eauto. - econstructor; eauto. assert (#|l0| + 0 = #|l0|) by lia. rewrite H. destruct pb; eauto. + - apply All2_length in Hl0. rewrite Hl0 in Rglob. clear Hl0 Hl0'. + apply eq_term_upto_univ_napp_mkApps; eauto. + econstructor; eauto. assert (#|l0| + 0 = #|l0|) by lia. rewrite H. destruct pb; eauto. } - apply red_terms_ws_cumul_pb_terms in Hl0, Hl0'. - etransitivity. - - eapply ws_cumul_pb_mkApps. - * refine (ws_cumul_pb_refl' (exist Γ Rclosed) (exist (tConstruct i k ui) _)); eauto. + apply red_terms_ws_cumul_pb_terms in Hl0, Hl0'. + etransitivity. + - eapply ws_cumul_pb_mkApps. + * refine (ws_cumul_pb_refl' (exist Γ Rclosed) (exist (tConstruct i k ui) _)); eauto. * eassumption. - cbn. etransitivity; try apply X. eapply ws_cumul_pb_mkApps. - * refine (ws_cumul_pb_refl' (exist Γ Rclosed) (exist (tConstruct i k ui') _)); eauto. + * refine (ws_cumul_pb_refl' (exist Γ Rclosed) (exist (tConstruct i k ui') _)); eauto. * symmetry. eassumption. Defined. @@ -3680,43 +3680,43 @@ Qed. Proposition cumulSpec_cumulAlgo {pb} (Γ : closed_context) (M N : open_term Γ) : Σ ;;; Γ ⊢ M ≤s[pb] N -> Σ ;;; Γ ⊢ M ≤[pb] N. -Proof. - destruct Γ as [Γ HΓ], M as [M HM], N as [N HN] ; cbn in *. +Proof. + destruct Γ as [Γ HΓ], M as [M HM], N as [N HN] ; cbn in *. unfold cumulSpec in *. intros e. - revert pb Γ M N e HΓ HM HN. + revert pb Γ M N e HΓ HM HN. apply: (cumulSpec0_ind_all Σ). 1-9: intros; subst; econstructor 2; eauto; try solve [econstructor; eauto]; - match goal with |- _ ;;; _ ⊢ ?t ≤[_] _ => + match goal with |- _ ;;; _ ⊢ ?t ≤[_] _ => eapply (ws_cumul_pb_refl' (exist Γ _) (exist t _)) end. - all: intro pb. - - intros; etransitivity; eauto. + all: intro pb. + - intros; etransitivity; eauto. - intros. apply ws_cumul_pb_eq_le_gen. apply symmetry. now apply X0. - intros Γ t; intros. unshelve eapply (ws_cumul_pb_refl' (exist Γ _) (exist t _)); eauto. - intros Γ ev args args' Hargsargs' HΓ Hargs Hargs'. cbn in *. eapply ws_cumul_pb_Evar; eauto. - apply forallb_All in Hargs, Hargs'. apply (All2_All_mix_left Hargs) in Hargsargs'. clear Hargs. + apply forallb_All in Hargs, Hargs'. apply (All2_All_mix_left Hargs) in Hargsargs'. clear Hargs. apply (All2_All_mix_right Hargs') in Hargsargs'. clear Hargs'. eapply All2_impl. 1: tea. cbn; intros x y [[Hx Heqxy ] Hy]. - eapply Heqxy; eauto. + eapply Heqxy; eauto. - intros Γ t t' u u' Htt' Heqtt' Huu' Hequu' HΓ HM HN. cbn in *; apply andb_andI in HM; apply andb_andI in HN; destruct HM as [Ht Hu]; destruct HN as [Ht' Hu']. eapply ws_cumul_pb_App; eauto. - - intros Γ na na' ty ty' t t' Hna Htyty' Heqtyty' Htt' Heqtt' HΓ HM HN. + - intros Γ na na' ty ty' t t' Hna Htyty' Heqtyty' Htt' Heqtt' HΓ HM HN. cbn in *. apply andb_andI in HM; apply andb_andI in HN; destruct HM as [Hty Ht]; destruct HN as [Hty' Ht']. - eapply ws_cumul_pb_Lambda; eauto. eapply Heqtt'; eauto. - * change (is_closed_context (Γ,, vass na ty)). rewrite on_free_vars_ctx_snoc. apply andb_and. split; eauto. + eapply ws_cumul_pb_Lambda; eauto. eapply Heqtt'; eauto. + * change (is_closed_context (Γ,, vass na ty)). rewrite on_free_vars_ctx_snoc. apply andb_and. split; eauto. * rewrite shiftnP_S; eauto. * rewrite shiftnP_S; eauto. - intros Γ na na' a a' b b' Hna Haa' foo IHe1 IHe2 HΓ HM HN. cbn in *; apply andb_andI in HM; apply andb_andI in HN; destruct HM as [Ha Hb]; destruct HN as [Ha' Hb']. - eapply ws_cumul_pb_Prod; eauto. eapply IHe2; eauto. - * change (is_closed_context (Γ,, vass na a)). rewrite on_free_vars_ctx_snoc. apply andb_and. split; eauto. + eapply ws_cumul_pb_Prod; eauto. eapply IHe2; eauto. + * change (is_closed_context (Γ,, vass na a)). rewrite on_free_vars_ctx_snoc. apply andb_and. split; eauto. * rewrite shiftnP_S; eauto. * rewrite shiftnP_S; eauto. - - intros Γ na na' t t' ty ty' u u' Hna _ Heqtt' _ Heqtyty' _ Hequu' HΓ HM HN. + - intros Γ na na' t t' ty ty' u u' Hna _ Heqtt' _ Heqtyty' _ Hequu' HΓ HM HN. cbn in *. apply andb_andI in HM; apply andb_andI in HN; destruct HM as [Ht Htyu]; destruct HN as [Ht' Htyu']. apply andb_andI in Htyu; apply andb_andI in Htyu'; destruct Htyu as [Hty Hu]; destruct Htyu' as [Hty' Hu']. - eapply ws_cumul_pb_LetIn; eauto. eapply Hequu'; eauto. + eapply ws_cumul_pb_LetIn; eauto. eapply Hequu'; eauto. * change (is_closed_context (Γ,, vdef na t ty)). rewrite on_free_vars_ctx_snoc. apply andb_and. split; eauto. - rewrite /on_free_vars_decl /test_decl. apply andb_and. split; eauto. + rewrite /on_free_vars_decl /test_decl. apply andb_and. split; eauto. * rewrite shiftnP_S; eauto. * rewrite shiftnP_S; eauto. - intros Γ indn p p' c c' brs brs' Hpp' _ Hcc' Hbrsbrs' HΓ H H'. @@ -3724,80 +3724,80 @@ Proof. apply andb_andI in H; apply andb_andI in H'; destruct H as [Hreturn H]; destruct H' as [Hreturn' H']. apply andb_andI in H; apply andb_andI in H'; destruct H as [Hcontext H]; destruct H' as [Hcontext' H']. apply andb_andI in H; apply andb_andI in H'; destruct H as [Hc Hbrs]; destruct H' as [Hc' Hbrs']. - eapply ws_cumul_pb_eq_le_gen. eapply ws_cumul_pb_Case; eauto. - * rewrite is_open_case_split. repeat (apply andb_and; split); eauto. - * rewrite is_open_case_split. repeat (apply andb_and; split); eauto. + eapply ws_cumul_pb_eq_le_gen. eapply ws_cumul_pb_Case; eauto. + * rewrite is_open_case_split. repeat (apply andb_and; split); eauto. + * rewrite is_open_case_split. repeat (apply andb_and; split); eauto. * unfold cumul_predicate in Hpp'. unfold ws_cumul_pb_predicate. destruct Hpp' as [Hpp' [Hinst [Hpcon Hpret]]]. split; eauto. - + clear - Hp Hp' Hpp' HΓ. apply forallb_All in Hp, Hp'. - apply (All2_All_mix_left Hp) in Hpp'. clear Hp. - apply (All2_All_mix_right Hp') in Hpp'. clear Hp'. - eapply All2_impl. 1: tea. cbn; intros x y [[Hx Heqxy ] Hy]. - eapply Heqxy.2; eauto. - + eapply Hpret; eauto. + + clear - Hp Hp' Hpp' HΓ. apply forallb_All in Hp, Hp'. + apply (All2_All_mix_left Hp) in Hpp'. clear Hp. + apply (All2_All_mix_right Hp') in Hpp'. clear Hp'. + eapply All2_impl. 1: tea. cbn; intros x y [[Hx Heqxy ] Hy]. + eapply Heqxy.2; eauto. + + eapply Hpret; eauto. ++ rewrite test_context_k_closed_on_free_vars_ctx in Hcontext. - unfold inst_case_predicate_context. apply PCUICOnFreeVarsConv.on_free_vars_ctx_inst_case_context ; eauto. + unfold inst_case_predicate_context. apply PCUICOnFreeVarsConv.on_free_vars_ctx_inst_case_context ; eauto. ++ rewrite shiftnP_add in Hreturn. rewrite <- inst_case_predicate_context_length in Hreturn. - rewrite <- app_length in Hreturn. eassumption. + rewrite <- app_length in Hreturn. eassumption. ++ rewrite shiftnP_add in Hreturn'. rewrite <- (All2_fold_length Hpcon) in Hreturn'. rewrite <- inst_case_predicate_context_length in Hreturn'. - rewrite <- app_length in Hreturn'. eassumption. + rewrite <- app_length in Hreturn'. eassumption. * unfold ws_cumul_pb_brs. clear - Hp Hp' Hbrs Hbrs' HΓ Hbrsbrs'. - apply forallb_All in Hbrs, Hbrs'. apply (All2_All_mix_left Hbrs) in Hbrsbrs'. clear Hbrs. - apply (All2_All_mix_right Hbrs') in Hbrsbrs'. clear Hbrs'. eapply All2_impl. 1: tea. cbn; intros x y [[Hx Heqxy ] Hy]. - split; try apply Heqxy.1. clear Hbrsbrs'. rewrite test_context_k_closed_on_free_vars_ctx in Hx. toProp Hx. - rewrite test_context_k_closed_on_free_vars_ctx in Hy. toProp Hy. eapply Heqxy.2; eauto. + apply forallb_All in Hbrs, Hbrs'. apply (All2_All_mix_left Hbrs) in Hbrsbrs'. clear Hbrs. + apply (All2_All_mix_right Hbrs') in Hbrsbrs'. clear Hbrs'. eapply All2_impl. 1: tea. cbn; intros x y [[Hx Heqxy ] Hy]. + split; try apply Heqxy.1. clear Hbrsbrs'. rewrite test_context_k_closed_on_free_vars_ctx in Hx. toProp Hx. + rewrite test_context_k_closed_on_free_vars_ctx in Hy. toProp Hy. eapply Heqxy.2; eauto. + apply PCUICOnFreeVarsConv.on_free_vars_ctx_inst_case_context ; eauto; intuition. + rewrite shiftnP_add in Hx. erewrite <- inst_case_branch_context_length in Hx. - rewrite <- app_length in Hx. intuition. + rewrite <- app_length in Hx. intuition. + rewrite shiftnP_add in Hy. rewrite <- (All2_fold_length Heqxy.1.1) in Hy. erewrite <- inst_case_branch_context_length in Hy. - rewrite <- app_length in Hy. intuition. + rewrite <- app_length in Hy. intuition. - intros; eapply ws_cumul_pb_Proj_c; eauto. - - intros Γ mfix mfix' idx Hmfixmfix' HΓ H H'. cbn in *. - eapply ws_cumul_pb_eq_le_gen. eapply ws_cumul_pb_Fix; eauto. apply forallb_All in H, H'. - apply (All2_All_mix_left H) in Hmfixmfix'. - apply (All2_All_mix_right H') in Hmfixmfix'. + - intros Γ mfix mfix' idx Hmfixmfix' HΓ H H'. cbn in *. + eapply ws_cumul_pb_eq_le_gen. eapply ws_cumul_pb_Fix; eauto. apply forallb_All in H, H'. + apply (All2_All_mix_left H) in Hmfixmfix'. + apply (All2_All_mix_right H') in Hmfixmfix'. eapply All2_impl. 1: tea. pose proof (Hfix := All2_length Hmfixmfix'); clear Hmfixmfix'; cbn; intros. destruct X as [[Hx [[ [_ [rtype _]] [rbody rargs]] rname]] Hy]. apply andb_andI in Hx; apply andb_andI in Hy; destruct Hx as [Hdtypex Hdbodyx]; destruct Hy as [Hdtypey Hdbodyy]. - repeat split; eauto. eapply rbody; eauto. + repeat split; eauto. eapply rbody; eauto. * rewrite on_free_vars_ctx_app; solve_all. rewrite on_free_vars_fix_context; eauto. * rewrite shiftnP_add in Hdbodyx. erewrite <- fix_context_length in Hdbodyx. - rewrite <- app_length in Hdbodyx. intuition. + rewrite <- app_length in Hdbodyx. intuition. * rewrite shiftnP_add in Hdbodyy. rewrite <- Hfix in Hdbodyy. erewrite <- fix_context_length in Hdbodyy. - rewrite <- app_length in Hdbodyy. intuition. - - intros Γ mfix mfix' idx Hmfixmfix' HΓ H H'. cbn in *. - eapply ws_cumul_pb_eq_le_gen. eapply ws_cumul_pb_CoFix; eauto. apply forallb_All in H, H'. - apply (All2_All_mix_left H) in Hmfixmfix'. - apply (All2_All_mix_right H') in Hmfixmfix'. + rewrite <- app_length in Hdbodyy. intuition. + - intros Γ mfix mfix' idx Hmfixmfix' HΓ H H'. cbn in *. + eapply ws_cumul_pb_eq_le_gen. eapply ws_cumul_pb_CoFix; eauto. apply forallb_All in H, H'. + apply (All2_All_mix_left H) in Hmfixmfix'. + apply (All2_All_mix_right H') in Hmfixmfix'. eapply All2_impl. 1: tea. pose proof (Hfix := All2_length Hmfixmfix'); clear Hmfixmfix'; cbn; intros. destruct X as [[Hx [[ [_ [rtype _]] [rbody rargs]] rname]] Hy]. apply andb_andI in Hx; apply andb_andI in Hy; destruct Hx as [Hdtypex Hdbodyx]; destruct Hy as [Hdtypey Hdbodyy]. - repeat split; eauto. eapply rbody; eauto. + repeat split; eauto. eapply rbody; eauto. * rewrite on_free_vars_ctx_app; solve_all. rewrite on_free_vars_fix_context; eauto. * rewrite shiftnP_add in Hdbodyx. erewrite <- fix_context_length in Hdbodyx. - rewrite <- app_length in Hdbodyx. intuition. + rewrite <- app_length in Hdbodyx. intuition. * rewrite shiftnP_add in Hdbodyy. rewrite <- Hfix in Hdbodyy. erewrite <- fix_context_length in Hdbodyy. - rewrite <- app_length in Hdbodyy. intuition. - - intros Γ i u u' args args' H X H0 H1 H2. eapply ws_cumul_pb_Ind; eauto. split; eauto. - rewrite on_free_vars_mkApps in H1. rewrite on_free_vars_mkApps in H2. - apply andb_and in H1, H2. destruct H1, H2. clear -X H0 H3 H4. - apply forallb_All in H3, H4. apply (All2_All_mix_left H3) in X. clear H3. - apply (All2_All_mix_right H4) in X. clear H4. eapply All2_impl. 1: tea. cbn; intros x y [[Hx Heqxy] Hy]. - eapply Heqxy.2; eauto. + rewrite <- app_length in Hdbodyy. intuition. + - intros Γ i u u' args args' H X H0 H1 H2. eapply ws_cumul_pb_Ind; eauto. split; eauto. + rewrite on_free_vars_mkApps in H1. rewrite on_free_vars_mkApps in H2. + apply andb_and in H1, H2. destruct H1, H2. clear -X H0 H3 H4. + apply forallb_All in H3, H4. apply (All2_All_mix_left H3) in X. clear H3. + apply (All2_All_mix_right H4) in X. clear H4. eapply All2_impl. 1: tea. cbn; intros x y [[Hx Heqxy] Hy]. + eapply Heqxy.2; eauto. - intros Γ i k u u' args args' H X H0 H1 H2. eapply ws_cumul_pb_Construct; eauto ; split; eauto. - rewrite on_free_vars_mkApps in H1. rewrite on_free_vars_mkApps in H2. - apply andb_and in H1, H2. destruct H1, H2. clear -X H0 H3 H4. - apply forallb_All in H3, H4. apply (All2_All_mix_left H3) in X. clear H3. - apply (All2_All_mix_right H4) in X. clear H4. eapply All2_impl. 1: tea. cbn; intros x y [[Hx Heqxy] Hy]. + rewrite on_free_vars_mkApps in H1. rewrite on_free_vars_mkApps in H2. + apply andb_and in H1, H2. destruct H1, H2. clear -X H0 H3 H4. + apply forallb_All in H3, H4. apply (All2_All_mix_left H3) in X. clear H3. + apply (All2_All_mix_right H4) in X. clear H4. eapply All2_impl. 1: tea. cbn; intros x y [[Hx Heqxy] Hy]. eapply Heqxy.2; eauto. - intros. econstructor 1; eauto. destruct pb; subst; econstructor; eauto. - intros. econstructor 1; eauto. destruct pb; subst; econstructor; eauto. - Unshelve. all: eauto. -Defined. + Unshelve. all: eauto. +Defined. Proposition convSpec_convAlgo (Γ : closed_context) (M N : open_term Γ) : Σ ;;; Γ |- M =s N -> Σ ;;; Γ ⊢ M = N. -Proof using wfΣ. +Proof using wfΣ. apply cumulSpec_cumulAlgo. Qed. diff --git a/pcuic/theories/PCUICCumulProp.v b/pcuic/theories/PCUICCumulProp.v index 57c02ef1e..df023f7bd 100644 --- a/pcuic/theories/PCUICCumulProp.v +++ b/pcuic/theories/PCUICCumulProp.v @@ -8,7 +8,7 @@ From MetaCoq.PCUIC Require Import PCUICTyping PCUICAst PCUICAstUtils PCUICTactic PCUICUnivSubstitutionTyp PCUICClosedTyp PCUICConversion PCUICCumulativity PCUICConfluence PCUICContexts PCUICSR PCUICInversion PCUICValidity PCUICSafeLemmata PCUICContextConversion - PCUICContextConversionTyp PCUICEquality PCUICReduction PCUICOnFreeVars + PCUICContextConversionTyp PCUICEquality PCUICReduction PCUICOnFreeVars PCUICWellScopedCumulativity PCUICInductiveInversion. @@ -45,7 +45,7 @@ Qed. Lemma cumul_ind_confluence {Σ : global_env_ext} {wfΣ : wf Σ} {Γ A ind u v l l'} : Σ ;;; Γ ⊢ A ≤ mkApps (tInd ind u) l -> Σ ;;; Γ ⊢ A ≤ mkApps (tInd ind v) l' -> - ∑ v' l'', + ∑ v' l'', [× Σ ;;; Γ ⊢ A ⇝ (mkApps (tInd ind v') l''), ws_cumul_pb_terms Σ Γ l l'', ws_cumul_pb_terms Σ Γ l' l'', @@ -62,9 +62,9 @@ Proof using Type. all:auto. exists u'u, args'; split; auto. - transitivity (mkApps (tInd ind u'u) l'u). auto. eapply closed_red_mkApps => //. - - eapply red_terms_ws_cumul_pb_terms in conv. + - eapply red_terms_ws_cumul_pb_terms in conv. transitivity l'u => //. now symmetry. - - eapply red_terms_ws_cumul_pb_terms in conv'. + - eapply red_terms_ws_cumul_pb_terms in conv'. transitivity l''u => //. now symmetry. Qed. @@ -109,23 +109,23 @@ Proof using Hcf'. unshelve eapply (leq_universe_sprop_l _ _ _ _ _ leq'); eauto. Qed. -Lemma prop_sort_eq {Σ Γ u u'} : Universe.is_prop u -> Universe.is_prop u' -> +Lemma prop_sort_eq {Σ Γ u u'} : Universe.is_prop u -> Universe.is_prop u' -> is_closed_context Γ -> Σ ;;; Γ ⊢ tSort u = tSort u'. Proof using Type. destruct u, u'; move=> //_ //_. - constructor => //. constructor. + constructor => //. constructor. red. red. constructor. Qed. -Lemma sprop_sort_eq {Σ Γ u u'} : Universe.is_sprop u -> Universe.is_sprop u' -> +Lemma sprop_sort_eq {Σ Γ u u'} : Universe.is_sprop u -> Universe.is_sprop u' -> is_closed_context Γ -> Σ ;;; Γ ⊢ tSort u = tSort u'. Proof using Type. destruct u, u'; move=> //_ //_. - constructor => //. constructor. + constructor => //. constructor. do 2 red. constructor. Qed. @@ -142,16 +142,16 @@ Qed. Lemma is_prop_superE {Σ l} : wf_ext Σ -> Universe.is_prop (Universe.super l) -> False. Proof using Hcf'. - intros wfΣ. + intros wfΣ. eapply is_prop_gt; eauto. eapply leq_universe_refl. Qed. Lemma is_sprop_superE {Σ l} : wf_ext Σ -> Universe.is_sprop (Universe.super l) -> False. Proof using Type. - intros wfΣ. destruct l => //. + intros wfΣ. destruct l => //. Qed. - + Lemma is_prop_prod {s s'} : Universe.is_prop s' -> Universe.is_prop (Universe.sort_of_product s s'). Proof using Type. intros isp. @@ -174,12 +174,12 @@ Definition eq_term_prop (Σ : global_env) napp := Reserved Notation " Σ ;;; Γ |- t ~~ u " (at level 50, Γ, t, u at next level). Inductive cumul_prop `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> term -> Type := - | cumul_refl t u : + | cumul_refl t u : is_closed_context Γ -> is_open_term Γ t -> is_open_term Γ u -> eq_term_prop Σ.1 0 t u -> Σ ;;; Γ |- t ~~ u - | cumul_red_l t u v : + | cumul_red_l t u v : is_closed_context Γ -> is_open_term Γ t -> is_open_term Γ u -> @@ -191,7 +191,7 @@ Inductive cumul_prop `{checker_flags} (Σ : global_env_ext) (Γ : context) : ter is_open_term Γ u -> is_open_term Γ v -> Σ ;;; Γ |- t ~~ v -> red1 Σ.1 Γ u v -> Σ ;;; Γ |- t ~~ u - + where " Σ ;;; Γ |- t ~~ u " := (cumul_prop Σ Γ t u) : type_scope. Lemma eq_term_prop_impl Σ Re Rle t u : @@ -205,7 +205,7 @@ Proof using Type. intros wfΣ n eq. intros. eapply PCUICEquality.eq_term_upto_univ_impl in eq. eauto. - all:auto. + all:auto. Qed. Lemma leq_universe_prop_spec Σ u1 u2 : @@ -228,7 +228,7 @@ Proof using Type. apply (leq_universe_props _ _ _ cu wf leq). Qed. -Lemma subrelation_eq_universe_eq_prop Σ : +Lemma subrelation_eq_universe_eq_prop Σ : wf_ext Σ -> subrelation (eq_universe Σ) eq_univ_prop. Proof using Hcf Hcf'. @@ -242,7 +242,7 @@ Proof using Hcf Hcf'. destruct x, y; simpl in *; auto; cong. Qed. -Lemma subrelation_leq_universe_eq_prop Σ : +Lemma subrelation_leq_universe_eq_prop Σ : wf_ext Σ -> subrelation (leq_universe Σ) eq_univ_prop. Proof using Hcf Hcf'. @@ -274,7 +274,7 @@ Proof using Hcf Hcf'. now apply subrelation_leq_universe_eq_prop. Qed. -Lemma cumul_cumul_prop Σ Γ A B : +Lemma cumul_cumul_prop Σ Γ A B : wf_ext Σ -> Σ ;;; Γ ⊢ A ≤ B -> Σ ;;; Γ |- A ~~ B. @@ -285,7 +285,7 @@ Proof using Hcf Hcf'. - econstructor 3; eauto. Qed. -Lemma conv_cumul_prop Σ Γ A B : +Lemma conv_cumul_prop Σ Γ A B : wf_ext Σ -> Σ ;;; Γ ⊢ A = B -> Σ ;;; Γ |- A ~~ B. @@ -309,7 +309,7 @@ Proof using Type. transitivity v; auto. apply redl. destruct IHX as [nf [nf' [redl redr eq]]]. exists nf, nf'; split; pcuic. - transitivity v; auto. + transitivity v; auto. apply into_closed_red; auto. - intros [nf [nf' [redv redv' eq]]]. assert (clnf := closed_red_open_right redv). @@ -326,7 +326,7 @@ Proof using Type. econstructor 2; eauto. Qed. -Lemma cumul_prop_props {Σ Γ u u'} {wfΣ : wf Σ}: +Lemma cumul_prop_props {Σ Γ u u'} {wfΣ : wf Σ}: Universe.is_prop u -> Σ ;;; Γ |- tSort u ~~ tSort u' -> Universe.is_prop u'. @@ -338,7 +338,7 @@ Proof using Type. depelim eq. red in e. intuition auto. Qed. -Lemma cumul_sprop_props {Σ Γ u u'} {wfΣ : wf Σ} : +Lemma cumul_sprop_props {Σ Γ u u'} {wfΣ : wf Σ} : Universe.is_sprop u -> Σ ;;; Γ |- tSort u ~~ tSort u' -> Universe.is_sprop u'. @@ -376,7 +376,7 @@ Proof using Type. intros H'; inv H'; intuition. Qed. -Lemma univ_expr_set_in_elements e s : +Lemma univ_expr_set_in_elements e s : LevelExprSet.In e s <-> In e (LevelExprSet.elements s). Proof using Type. rewrite -LevelExprSet.elements_spec1. generalize (LevelExprSet.elements s). @@ -390,12 +390,12 @@ Proof using Type. intros e. unfold NonEmptySetFacts.map. pose proof (NonEmptySetFacts.to_nonempty_list_spec s). - destruct (NonEmptySetFacts.to_nonempty_list s) as [e' l] eqn:eq. + destruct (NonEmptySetFacts.to_nonempty_list s) as [e' l] eqn:eq. rewrite -univ_expr_set_in_elements NonEmptySetFacts.add_list_spec. rewrite -H. simpl. rewrite LevelExprSet.singleton_spec. intuition auto. Qed. - + Lemma Forall_elements_in P s : Forall P (LevelExprSet.elements s) <-> (forall x, LevelExprSet.In x s -> P x). Proof using Type. @@ -409,7 +409,7 @@ Proof using Type. apply IHl. intros x inxl. apply H. right; auto. Qed. -Lemma univ_exprs_map_all P g s : +Lemma univ_exprs_map_all P g s : Forall P (LevelExprSet.elements (NonEmptySetFacts.map g s)) <-> Forall (fun x => P (g x)) (LevelExprSet.elements s). Proof using Type. @@ -420,7 +420,7 @@ Proof using Type. destruct H0 as [e' [ins ->]]. apply H; auto. Qed. -Lemma expr_set_forall_map f g s : +Lemma expr_set_forall_map f g s : LevelExprSet.for_all f (NonEmptySetFacts.map g s) <-> LevelExprSet.for_all (fun e => f (g e)) s. Proof using Type. @@ -433,7 +433,7 @@ Proof using Type. destruct x; simpl; auto. Qed. -(* Lemma is_prop_subst_level_expr u1 u2 s : +(* Lemma is_prop_subst_level_expr u1 u2 s : Forall2 (fun x y : Level.t => eq_univ_prop (Universe.make x) (Universe.make y)) u1 u2 -> LevelExpr.is_prop (subst_instance_level_expr u1 s) = LevelExpr.is_prop (subst_instance_level_expr u2 s). Proof. @@ -458,7 +458,7 @@ Proof using Type. destruct s; red; simpl; auto; try intuition reflexivity. Qed. -Lemma cumul_prop_sym Σ Γ T U : +Lemma cumul_prop_sym Σ Γ T U : wf Σ.1 -> Σ ;;; Γ |- T ~~ U -> Σ ;;; Γ |- U ~~ T. @@ -470,7 +470,7 @@ Proof using Type. now symmetry. Qed. -Lemma cumul_prop_trans Σ Γ T U V : +Lemma cumul_prop_trans Σ Γ T U V : wf Σ -> Σ ;;; Γ |- T ~~ U -> Σ ;;; Γ |- U ~~ V -> @@ -494,8 +494,8 @@ Qed. Global Instance cumul_prop_transitive Σ Γ : wf Σ -> CRelationClasses.Transitive (cumul_prop Σ Γ). Proof using Type. intros. red. intros. now eapply cumul_prop_trans. Qed. -Lemma cumul_prop_cum_l {Σ Γ A T B} {wfΣ : wf_ext Σ} : - Σ ;;; Γ |- A ~~ T -> +Lemma cumul_prop_cum_l {Σ Γ A T B} {wfΣ : wf_ext Σ} : + Σ ;;; Γ |- A ~~ T -> Σ ;;; Γ ⊢ A ≤ B -> Σ ;;; Γ |- B ~~ T. Proof using Hcf Hcf'. @@ -506,7 +506,7 @@ Proof using Hcf Hcf'. Qed. Lemma cumul_prop_cum_r {Σ Γ A T B} {wfΣ : wf_ext Σ} : - Σ ;;; Γ |- A ~~ T -> + Σ ;;; Γ |- A ~~ T -> Σ ;;; Γ ⊢ B ≤ A -> Σ ;;; Γ |- B ~~ T. Proof using Hcf Hcf'. @@ -516,7 +516,7 @@ Proof using Hcf Hcf'. Qed. Lemma cumul_prop_conv_l {Σ Γ A T B} {wfΣ : wf_ext Σ} : - Σ ;;; Γ |- A ~~ T -> + Σ ;;; Γ |- A ~~ T -> Σ ;;; Γ ⊢ A = B -> Σ ;;; Γ |- B ~~ T. Proof using Hcf Hcf'. @@ -527,7 +527,7 @@ Proof using Hcf Hcf'. Qed. Lemma cumul_prop_conv_r {Σ Γ A T B} {wfΣ : wf_ext Σ} : - Σ ;;; Γ |- A ~~ T -> + Σ ;;; Γ |- A ~~ T -> Σ ;;; Γ ⊢ B = A -> Σ ;;; Γ |- B ~~ T. Proof using Hcf Hcf'. @@ -566,7 +566,7 @@ Lemma red1_upto_conv_ctx_prop Σ Γ Γ' t t' : conv_ctx_prop Σ Γ Γ' -> red1 Σ.1 Γ' t t'. Proof using Type. - intros Hred; induction Hred using red1_ind_all in Γ' |- *; + intros Hred; induction Hred using red1_ind_all in Γ' |- *; try solve [econstructor; eauto; try solve [solve_all]]. - econstructor. destruct (nth_error Γ i) eqn:eq; simpl in H => //. noconf H; simpl in H; noconf H. @@ -598,7 +598,7 @@ Proof using Type. intros clΓ' [] conv. eapply red1_upto_conv_ctx_prop in clrel_rel; eauto. split; auto. - now rewrite -(All2_fold_length conv). + now rewrite -(All2_fold_length conv). Qed. Lemma red_upto_conv_ctx_prop Σ Γ Γ' t t' : @@ -621,7 +621,7 @@ Proof using Type. intros clΓ' [] conv. eapply red_upto_conv_ctx_prop in clrel_rel; eauto. split; auto. - now rewrite -(All2_fold_length conv). + now rewrite -(All2_fold_length conv). Qed. Lemma cumul_prop_prod_inv {Σ Γ na A B na' A' B'} {wfΣ : wf Σ} : @@ -667,7 +667,7 @@ Proof using Type. now eapply subslet_untyped_subslet. Qed. -Lemma substitution_untyped_cumul_prop_equiv {Σ Γ Δ Γ' s s' M} {wfΣ : wf Σ} : +Lemma substitution_untyped_cumul_prop_equiv {Σ Γ Δ Γ' s s' M} {wfΣ : wf Σ} : is_closed_context (Γ ,,, Δ ,,, Γ') -> forallb (is_open_term Γ) s -> forallb (is_open_term Γ) s' -> @@ -704,12 +704,12 @@ Proof using Type. move/andP => []; split; auto. unfold ws_decl in b. destruct d as [na [bod|] ty]; cbn in *; auto. move/andP: b => /= [] clb clt. - unfold closed_decl. cbn. + unfold closed_decl. cbn. now rewrite !closedP_on_free_vars clb clt. now rewrite closedP_on_free_vars. Qed. -Lemma red_conv_prop {Σ Γ T U} {wfΣ : wf_ext Σ} : +Lemma red_conv_prop {Σ Γ T U} {wfΣ : wf_ext Σ} : Σ ;;; Γ ⊢ T ⇝ U -> Σ ;;; Γ |- T ~~ U. Proof using Hcf Hcf'. @@ -717,7 +717,7 @@ Proof using Hcf Hcf'. now apply conv_cumul_prop. Qed. -Lemma substitution_red_terms_conv_prop {Σ Γ Δ Γ' s s' M} {wfΣ : wf_ext Σ} : +Lemma substitution_red_terms_conv_prop {Σ Γ Δ Γ' s s' M} {wfΣ : wf_ext Σ} : is_closed_context (Γ ,,, Δ ,,, Γ') -> is_open_term (Γ ,,, Δ ,,, Γ') M -> untyped_subslet Γ s Δ -> @@ -729,7 +729,7 @@ Proof using Hcf Hcf'. eapply closed_red_red_subst; tea. Qed. -Lemma context_conversion_cumul_prop {Σ Γ Δ M N} {wfΣ : wf_ext Σ} : +Lemma context_conversion_cumul_prop {Σ Γ Δ M N} {wfΣ : wf_ext Σ} : Σ ;;; Γ |- M ~~ N -> Σ ⊢ Γ = Δ -> Σ ;;; Δ |- M ~~ N. @@ -755,11 +755,11 @@ Proof using Hcf Hcf'. symmetry in X1. now eapply conv_cumul_prop. Qed. -(** Note: a more general version involving substitution in an extended context Γ ,,, Δ would be +(** Note: a more general version involving substitution in an extended context Γ ,,, Δ would be harder as it requires a more involved proof about reduction being "preserved" when converting contexts using cumul_prop rather than standard conversion. *) -Lemma substitution_untyped_cumul_prop_cumul {Σ Γ Δ Δ' s s' M} {wfΣ : wf_ext Σ} : +Lemma substitution_untyped_cumul_prop_cumul {Σ Γ Δ Δ' s s' M} {wfΣ : wf_ext Σ} : is_closed_context (Γ ,,, Δ) -> is_closed_context (Γ ,,, Δ') -> is_open_term (Γ ,,, Δ) M -> @@ -776,10 +776,10 @@ Proof using Hcf Hcf'. * transitivity (subst0 nf' M). constructor. - rewrite on_free_vars_ctx_app in clctx. now move/andP: clctx. - - eapply (is_open_term_subst (Γ' := [])). apply clctx. + - eapply (is_open_term_subst (Γ' := [])). apply clctx. eapply closed_red_terms_open_right in redl. solve_all. now rewrite -(All2_length redl) -(untyped_subslet_length subs). apply clM. - - eapply (is_open_term_subst (Γ' := [])). apply clctx. + - eapply (is_open_term_subst (Γ' := [])). apply clctx. eapply closed_red_terms_open_right in redr. solve_all. now rewrite -(All2_length redr) -(untyped_subslet_length subs). apply clM. - eapply PCUICEquality.eq_term_upto_univ_substs => //. reflexivity. @@ -805,7 +805,7 @@ Proof using Type. destruct l; simpl; auto. Qed. -Lemma R_opt_variance_impl Re Rle v x y : +Lemma R_opt_variance_impl Re Rle v x y : subrelation Re Rle -> R_universe_instance Re x y -> R_opt_variance Re Rle v x y. @@ -819,7 +819,7 @@ Proof using Type. eauto. Qed. -Lemma cumul_prop_subst_instance_instance Σ univs u u' (i : Instance.t) : +Lemma cumul_prop_subst_instance_instance Σ univs u u' (i : Instance.t) : wf Σ.1 -> consistent_instance_ext Σ univs u -> consistent_instance_ext Σ univs u' -> @@ -835,7 +835,7 @@ Proof using Type. Qed. Lemma cumul_prop_subst_instance {Σ Γ univs u u' T} {wfΣ : wf Σ} : - is_closed_context Γ -> + is_closed_context Γ -> is_open_term Γ T -> consistent_instance_ext Σ univs u -> consistent_instance_ext Σ univs u' -> @@ -849,14 +849,14 @@ Proof using Type. eexists _, _; split; intuition auto. clear clΓ clT. induction T using PCUICInduction.term_forall_list_ind; cbn; intros; try solve [constructor; eauto; solve_all]. - - cbn. constructor. + - cbn. constructor. destruct s; split; reflexivity. - constructor. eapply PCUICEquality.eq_term_upto_univ_impl in IHT1; eauto. all:try typeclasses eauto. apply IHT2. - constructor. now eapply cumul_prop_subst_instance_instance. - constructor. red. apply R_opt_variance_impl. intros x y; auto. - now eapply cumul_prop_subst_instance_instance. + now eapply cumul_prop_subst_instance_instance. - constructor. red. apply R_opt_variance_impl. intros x y; auto. now eapply cumul_prop_subst_instance_instance. - cbn. constructor. splits; simpl; solve_all. @@ -867,7 +867,7 @@ Proof using Type. intuition auto. rewrite /id. reflexivity. Qed. -Lemma R_eq_univ_prop_consistent_instances Σ univs u u' : +Lemma R_eq_univ_prop_consistent_instances Σ univs u u' : wf Σ.1 -> consistent_instance_ext Σ univs u -> consistent_instance_ext Σ univs u' -> @@ -898,7 +898,7 @@ Proof using Type. simpl. rewrite app_length /= => Hlen. unfold arities_context. simpl. rewrite /arities_context rev_map_spec /=. - rewrite map_app /= rev_app_distr /=. + rewrite map_app /= rev_app_distr /=. rewrite /= Nat.add_1_r /=. constructor. rewrite -rev_map_spec. apply IHl. lia. @@ -916,7 +916,7 @@ Proof using Hcf Hcf'. eapply cumul_prop_alt in cum as (nf & nf' & [redl redr eq']). eapply cumul_prop_alt. eexists (tProd na t nf), (tProd na' t' nf'); split; eauto. - eapply closed_red_prod_codom; auto. - - eapply clrel_ctx in redl. + - eapply clrel_ctx in redl. move: redl; rewrite on_free_vars_ctx_snoc /= => /andP[]; rewrite /on_free_vars_decl /test_decl /= => onΓ ont. have clt' : is_open_term Γ t'. eapply PCUICConfluence.eq_term_upto_univ_napp_on_free_vars in eq; tea. @@ -938,7 +938,7 @@ Lemma cumul_prop_tLetIn (Σ : global_env_ext) {Γ na t d ty na' t' d' ty'} {wfΣ Proof using Hcf Hcf'. intros eqann eq eq' cum. eapply cumul_prop_alt in cum as (nf & nf' & [redl redr eq'']). - eapply cumul_prop_alt. + eapply cumul_prop_alt. assert(eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) (Γ ,, vdef na d t) (Γ ,, vdef na' d' t')). { repeat constructor; pcuic. eapply eq_context_upto_refl; typeclasses eauto. } eapply (closed_red_eq_context_upto_l (pb:=Conv)) in redr; eauto. @@ -959,7 +959,7 @@ Proof using Hcf Hcf'. Qed. Lemma cumul_prop_mkApps {Σ Γ f args f' args'} {wfΣ : wf_ext Σ} : - is_closed_context Γ -> + is_closed_context Γ -> is_open_term Γ f -> is_open_term Γ f' -> eq_term Σ.1 Σ f f' -> @@ -1017,7 +1017,7 @@ Proof using Type. eapply All2_impl; eauto. eapply red_cumul_prop. eapply All2_trans. typeclasses eauto. 2:{ eapply All2_symP. intros x y H; now eapply cumul_prop_sym. - eapply All2_impl; eauto. eapply red_cumul_prop. } + eapply All2_impl; eauto. eapply red_cumul_prop. } eapply eq_term_prop_mkApps_inv in eq' => //. eapply closed_red_terms_open_right in eqargs. eapply closed_red_terms_open_right in eqargs'. @@ -1034,15 +1034,15 @@ Notation eq_term_napp Σ n x y := Notation leq_term_napp Σ n x y := (eq_term_upto_univ_napp Σ (eq_universe Σ) (leq_universe Σ) n x y). - + Lemma eq_term_upto_univ_napp_leq {Σ : global_env_ext} {n x y} : - eq_term_napp Σ n x y -> + eq_term_napp Σ n x y -> leq_term_napp Σ n x y. Proof using Type. eapply eq_term_upto_univ_impl; auto; typeclasses eauto. Qed. -Lemma cumul_prop_is_open {Σ Γ T U} : +Lemma cumul_prop_is_open {Σ Γ T U} : Σ ;;; Γ |- T ~~ U -> [× is_closed_context Γ, is_open_term Γ T & is_open_term Γ U]. Proof using Type. @@ -1084,13 +1084,13 @@ Lemma typing_leq_term_prop (Σ : global_env_ext) Γ t t' T T' : Proof using Hcf Hcf'. intros wfΣ Ht. revert Σ wfΣ Γ t T Ht t' T'. - eapply (typing_ind_env + eapply (typing_ind_env (fun Σ Γ t T => forall t' T' : term, on_udecl Σ.1 Σ.2 -> Σ;;; Γ |- t' : T' -> forall n, leq_term_napp Σ n t' t -> - Σ ;;; Γ |- T ~~ T')%type + Σ ;;; Γ |- T ~~ T')%type (fun Σ Γ => wf_local Σ Γ)); auto;intros Σ wfΣ Γ wfΓ; intros. 1-13:match goal with @@ -1116,7 +1116,7 @@ Proof using Hcf Hcf'. rewrite shiftnP_add. now eapply cumul_prop_is_open in X3 as []. eapply eq_term_eq_term_prop_impl => //. eapply PCUICEquality.eq_term_upto_univ_substs. - all:try typeclasses eauto. + all:try typeclasses eauto. eapply PCUICEquality.eq_term_upto_univ_refl. all:try typeclasses eauto. constructor. 2:constructor. now symmetry. } @@ -1133,7 +1133,7 @@ Proof using Hcf Hcf'. 1,2:now eapply is_sprop_superE in H'. - eapply inversion_Prod in X4 as [s1' [s2' [Ha [Hb Hs]]]]; auto. - specialize (X1 _ _ H Ha). + specialize (X1 _ _ H Ha). specialize (X1 _ (eq_term_upto_univ_napp_leq X5_1)). eapply context_conversion in Hb. 3:{ constructor. apply conv_ctx_refl. constructor. eassumption. @@ -1151,7 +1151,7 @@ Proof using Hcf Hcf'. - eapply inversion_Lambda in X4 as (s & B & dom & bod & cum). specialize (X1 _ _ H dom _ (eq_term_upto_univ_napp_leq X5_1)). - specialize (X3 t0 B H). + specialize (X3 t0 B H). assert(conv_context cumulAlgo_gen Σ (Γ ,, vass na ty) (Γ ,, vass n t)). { repeat constructor; pcuic. } forward X3 by eapply context_conversion; eauto; pcuic. @@ -1176,7 +1176,7 @@ Proof using Hcf Hcf'. eapply cumul_prop_trans; eauto. pose proof (declared_constant_inj _ _ H declc); subst decl'. eapply cumul_prop_subst_instance; eauto. fvs. - destruct (cumul_prop_is_open cum) as []. + destruct (cumul_prop_is_open cum) as []. now rewrite on_free_vars_subst_instance in i0. - eapply inversion_Ind in X1 as [decl' [idecl' [wf [declc [cu cum]]]]]; auto. @@ -1184,7 +1184,7 @@ Proof using Hcf Hcf'. eapply cumul_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. eapply cumul_prop_subst_instance; tea. fvs. - destruct (cumul_prop_is_open cum) as []. + destruct (cumul_prop_is_open cum) as []. now rewrite on_free_vars_subst_instance in i0. - eapply inversion_Construct in X1 as [decl' [idecl' [cdecl' [wf [declc [cu cum]]]]]]; auto. @@ -1198,7 +1198,7 @@ Proof using Hcf Hcf'. { eapply closedn_on_free_vars, closed_upwards. eapply PCUICClosedTyp.declared_constructor_closed_gen_type; tea. len. } rewrite on_free_vars_ctx_subst_instance in clars. - etransitivity. + etransitivity. eapply (@substitution_untyped_cumul_prop_equiv _ Γ (subst_instance u (arities_context mdecl.(ind_bodies))) []); auto. * simpl. apply is_closed_context_weaken. fvs. @@ -1231,7 +1231,7 @@ Proof using Hcf Hcf'. specialize (X7 _ _ H5 scrut_ty _ (eq_term_upto_univ_napp_leq X10)). eapply cumul_prop_sym => //. destruct e as [eqpars [eqinst [eqpctx eqpret]]]. - rewrite /ptm. + rewrite /ptm. eapply cumul_prop_mkApps => //. fvs. { eapply cumul_prop_is_open in cum as []. rewrite on_free_vars_mkApps in i0. @@ -1253,7 +1253,7 @@ Proof using Hcf Hcf'. move: (All2_length eqpars). move: (All2_length a0). lia. fvs. now eapply subject_is_open_term in scrut_ty. now apply subject_is_open_term in X6. - + - eapply inversion_Proj in X3 as (u' & mdecl' & idecl' & cdecl' & pdecl' & args' & inv); auto. intuition auto. specialize (X2 _ _ H0 a0 _ (eq_term_upto_univ_napp_leq X4)). @@ -1303,7 +1303,7 @@ Proof using Hcf Hcf'. { now eapply cumul_prop_is_open in cum as []. } eapply eq_term_eq_term_prop_impl; eauto. now symmetry in a. - + - eapply inversion_CoFix in X2 as (decl' & fixguard' & Hnth & types' & bodies & wfcofix & cum); auto. eapply cumul_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. diff --git a/pcuic/theories/PCUICCumulativity.v b/pcuic/theories/PCUICCumulativity.v index 82a2ac0fa..5b2a34c67 100644 --- a/pcuic/theories/PCUICCumulativity.v +++ b/pcuic/theories/PCUICCumulativity.v @@ -53,7 +53,7 @@ Instance conv_decls_refl {cf:checker_flags} Σ Γ Γ' : Reflexive (conv_decls cu Instance cumul_decls_refl {cf:checker_flags} Σ Γ Γ' : Reflexive (cumul_decls cumulAlgo_gen Σ Γ Γ') := _. Lemma cumul_alt `{cf : checker_flags} Σ Γ t u : - Σ ;;; Γ |- t <= u <~> { v & { v' & (red Σ Γ t v * red Σ Γ u v' * + Σ ;;; Γ |- t <= u <~> { v & { v' & (red Σ Γ t v * red Σ Γ u v' * leq_term_ext Σ (leq_universe Σ) v v')%type } }. Proof. split. @@ -154,7 +154,7 @@ Proof. intros H%clos_rt_rt1n_iff. induction H. - reflexivity. - - econstructor 2; eauto. + - econstructor 2; eauto. Qed. #[global] @@ -168,7 +168,7 @@ Proof. Qed. Lemma eq_term_eq_term_napp {cf:checker_flags} Σ ϕ napp t t' : - eq_term Σ ϕ t t' -> + eq_term Σ ϕ t t' -> eq_term_upto_univ_napp Σ (eq_universe ϕ) (eq_universe ϕ) napp t t'. Proof. intros. eapply eq_term_upto_univ_impl. 5:eauto. @@ -176,7 +176,7 @@ Proof. Qed. Lemma leq_term_leq_term_napp {cf:checker_flags} Σ ϕ napp t t' : - leq_term Σ ϕ t t' -> + leq_term Σ ϕ t t' -> eq_term_upto_univ_napp Σ (eq_universe ϕ) (leq_universe ϕ) napp t t'. Proof. intros. eapply eq_term_upto_univ_impl. 5:eauto. @@ -249,7 +249,7 @@ Proof. Qed. Lemma conv_alt_red {cf : checker_flags} {Σ : global_env_ext} {Γ : context} {t u : term} : - Σ;;; Γ |- t = u <~> (∑ v v' : term, (red Σ Γ t v × red Σ Γ u v') × + Σ;;; Γ |- t = u <~> (∑ v v' : term, (red Σ Γ t v × red Σ Γ u v') × eq_term Σ (global_ext_constraints Σ) v v'). Proof. split. @@ -305,7 +305,7 @@ Section ContextConversion. Global Instance conv_ctx_refl : Reflexive (All2_fold (conv_decls cumulAlgo_gen Σ)). Proof using Type. intro Γ; induction Γ; try econstructor; auto. - destruct a as [na [b|] ty]; constructor; auto; pcuic; eapply conv_refl'. + destruct a as [na [b|] ty]; constructor; auto; pcuic; eapply conv_refl'. Qed. Global Instance cumul_ctx_refl : Reflexive (All2_fold (cumul_decls cumulAlgo_gen Σ)). diff --git a/pcuic/theories/PCUICCumulativitySpec.v b/pcuic/theories/PCUICCumulativitySpec.v index 3dc66296c..b7d26f3e2 100644 --- a/pcuic/theories/PCUICCumulativitySpec.v +++ b/pcuic/theories/PCUICCumulativitySpec.v @@ -31,16 +31,16 @@ Inductive cumulSpec0 {cf : checker_flags} (Σ : global_env_ext) Γ (pb : conv_pb (* transitivity *) | cumul_Trans : forall t u v, - is_closed_context Γ -> is_open_term Γ u -> + is_closed_context Γ -> is_open_term Γ u -> Σ ;;; Γ ⊢ t ≤s[pb] u -> - Σ ;;; Γ ⊢ u ≤s[pb] v -> - Σ ;;; Γ ⊢ t ≤s[pb] v + Σ ;;; Γ ⊢ u ≤s[pb] v -> + Σ ;;; Γ ⊢ t ≤s[pb] v (* symmetry *) -| cumul_Sym : forall t u, +| cumul_Sym : forall t u, Σ ;;; Γ ⊢ t ≤s[Conv] u -> - Σ ;;; Γ ⊢ u ≤s[pb] t + Σ ;;; Γ ⊢ u ≤s[pb] t (* reflexivity *) @@ -49,7 +49,7 @@ Inductive cumulSpec0 {cf : checker_flags} (Σ : global_env_ext) Γ (pb : conv_pb (* Cumulativity rules *) -| cumul_Ind : forall i u u' args args', +| cumul_Ind : forall i u u' args args', cumul_Ind_univ Σ pb i #|args| u u' -> All2 (fun t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) args args' -> Σ ;;; Γ ⊢ mkApps (tInd i u) args ≤s[pb] mkApps (tInd i u') args' @@ -58,7 +58,7 @@ Inductive cumulSpec0 {cf : checker_flags} (Σ : global_env_ext) Γ (pb : conv_pb cumul_Construct_univ Σ pb i k #|args| u u' -> All2 (fun t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) args args' -> Σ ;;; Γ ⊢ mkApps (tConstruct i k u) args ≤s[pb] mkApps (tConstruct i k u') args' - + | cumul_Sort : forall s s', compare_universe pb Σ s s' -> Σ ;;; Γ ⊢ tSort s ≤s[pb] tSort s' @@ -69,11 +69,11 @@ Inductive cumulSpec0 {cf : checker_flags} (Σ : global_env_ext) Γ (pb : conv_pb (* congruence rules *) -| cumul_Evar : forall e args args', +| cumul_Evar : forall e args args', All2 (fun t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) args args' -> Σ ;;; Γ ⊢ tEvar e args ≤s[pb] tEvar e args' -| cumul_App : forall t t' u u', +| cumul_App : forall t t' u u', Σ ;;; Γ ⊢ t ≤s[pb] t' -> Σ ;;; Γ ⊢ u ≤s[Conv] u' -> Σ ;;; Γ ⊢ tApp t u ≤s[pb] tApp t' u' @@ -90,23 +90,23 @@ Inductive cumulSpec0 {cf : checker_flags} (Σ : global_env_ext) Γ (pb : conv_pb Σ ;;; Γ ,, vass na a ⊢ b ≤s[pb] b' -> Σ ;;; Γ ⊢ tProd na a b ≤s[pb] tProd na' a' b' -| cumul_LetIn : forall na na' t t' ty ty' u u', +| cumul_LetIn : forall na na' t t' ty ty' u u', eq_binder_annot na na' -> Σ ;;; Γ ⊢ t ≤s[Conv] t' -> Σ ;;; Γ ⊢ ty ≤s[Conv] ty' -> Σ ;;; Γ ,, vdef na t ty ⊢ u ≤s[pb] u' -> Σ ;;; Γ ⊢ tLetIn na t ty u ≤s[pb] tLetIn na' t' ty' u' -| cumul_Case indn : forall p p' c c' brs brs', +| cumul_Case indn : forall p p' c c' brs brs', cumul_predicate (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) Γ (compare_universe Conv Σ) p p' -> Σ ;;; Γ ⊢ c ≤s[Conv] c' -> All2 (fun br br' => - eq_context_gen eq eq (bcontext br) (bcontext br') × + eq_context_gen eq eq (bcontext br) (bcontext br') × Σ ;;; Γ ,,, inst_case_branch_context p br ⊢ bbody br ≤s[Conv] bbody br' ) brs brs' -> Σ ;;; Γ ⊢ tCase indn p c brs ≤s[pb] tCase indn p' c' brs' -| cumul_Proj : forall p c c', +| cumul_Proj : forall p c c', Σ ;;; Γ ⊢ c ≤s[Conv] c' -> Σ ;;; Γ ⊢ tProj p c ≤s[pb] tProj p c' @@ -143,7 +143,7 @@ Inductive cumulSpec0 {cf : checker_flags} (Σ : global_env_ext) Γ (pb : conv_pb Σ ;;; Γ ⊢ tRel i ≤s[pb] lift0 (S i) body (** iota red *) -| cumul_iota : forall ci c u args p brs br, +| cumul_iota : forall ci c u args p brs br, nth_error brs c = Some br -> #|args| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat -> Σ ;;; Γ ⊢ tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs ≤s[pb] iota_red ci.(ci_npar) p args br @@ -183,7 +183,7 @@ Definition cumulSpec `{checker_flags} (Σ : global_env_ext) Γ := cumulSpec0 Σ Notation " Σ ;;; Γ |- t <=s u " := (@cumulSpec _ Σ Γ t u) (at level 50, Γ, t, u at next level). Notation " Σ ;;; Γ |- t =s u " := (@convSpec _ Σ Γ t u) (at level 50, Γ, t, u at next level). - + Include PCUICConversion. Module PCUICConversionParSpec <: EnvironmentTyping.ConversionParSig PCUICTerm PCUICEnvironment PCUICTermUtils PCUICEnvTyping. @@ -205,7 +205,7 @@ Instance conv_refl' {cf:checker_flags} Σ Γ : Reflexive (convSpec Σ Γ) := _. #[global] Instance cumul_pb_decls_refl {cf:checker_flags} pb Σ Γ Γ' : Reflexive (cumul_pb_decls cumulSpec0 pb Σ Γ Γ'). Proof. - intros x. destruct x as [na [b|] ty]; constructor; auto. + intros x. destruct x as [na [b|] ty]; constructor; auto. all:constructor; reflexivity. Qed. @@ -218,7 +218,7 @@ Section ContextConversion. Context {cf : checker_flags}. Context (Σ : global_env_ext). - Notation conv_context := (conv_context cumulSpec0 Σ). + Notation conv_context := (conv_context cumulSpec0 Σ). Notation cumul_context := (cumul_context cumulSpec0 Σ). Global Instance cumul_pb_ctx_refl pb : Reflexive (cumul_pb_context cumulSpec0 pb Σ). @@ -301,24 +301,24 @@ Lemma cumulSpec0_ind_all : (* reflexivity *) (forall (pb : conv_pb) (Γ : context) (t : term), P pb Γ t t) -> - + (* congruence rules *) (forall (pb : conv_pb) (Γ : context) (ev : nat) (l l' : list term), All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Conv Γ)) l l' -> P pb Γ (tEvar ev l) (tEvar ev l')) -> - (forall (pb : conv_pb) (Γ : context) (t t' u u' : term), + (forall (pb : conv_pb) (Γ : context) (t t' u u' : term), cumulSpec0 Σ Γ pb t t' -> P pb Γ t t' -> cumulSpec0 Σ Γ Conv u u' -> P Conv Γ u u' -> P pb Γ (tApp t u) (tApp t' u')) -> (forall (pb : conv_pb) (Γ : context) (na na' : aname) (ty ty' t t' : term), - eq_binder_annot na na' -> - cumulSpec0 Σ Γ Conv ty ty' -> P Conv Γ ty ty' -> - cumulSpec0 Σ (Γ ,, vass na ty) pb t t' -> P pb (Γ ,, vass na ty) t t' -> + eq_binder_annot na na' -> + cumulSpec0 Σ Γ Conv ty ty' -> P Conv Γ ty ty' -> + cumulSpec0 Σ (Γ ,, vass na ty) pb t t' -> P pb (Γ ,, vass na ty) t t' -> P pb Γ (tLambda na ty t) (tLambda na' ty' t')) -> - (forall (pb : conv_pb) (Γ : context) (na na' : binder_annot name) (a a' b b' : term), + (forall (pb : conv_pb) (Γ : context) (na na' : binder_annot name) (a a' b b' : term), eq_binder_annot na na' -> cumulSpec0 Σ Γ Conv a a' -> P Conv Γ a a' -> cumulSpec0 Σ (Γ,, vass na a) pb b b' -> P pb (Γ,, vass na a) b b' -> @@ -332,68 +332,68 @@ Lemma cumulSpec0_ind_all : (forall (pb : conv_pb) (Γ : context) (indn : case_info) (p p' : predicate term) (c c' : term) (brs brs' : list (branch term)), - cumul_predicate (fun Γ t u => cumulSpec0 Σ Γ Conv t u × P Conv Γ t u) Γ - (compare_universe Conv Σ) p p' -> + cumul_predicate (fun Γ t u => cumulSpec0 Σ Γ Conv t u × P Conv Γ t u) Γ + (compare_universe Conv Σ) p p' -> cumulSpec0 Σ Γ Conv c c' -> P Conv Γ c c' -> All2 (Trel_conj (fun br br' : branch term => eq_context_gen eq eq (bcontext br) (bcontext br') * cumulSpec0 Σ (Γ,,, inst_case_branch_context p br) Conv - (bbody br) (bbody br')) - (fun br br' => P Conv (Γ,,, inst_case_branch_context p br) (bbody br) (bbody br'))) brs brs' -> + (bbody br) (bbody br')) + (fun br br' => P Conv (Γ,,, inst_case_branch_context p br) (bbody br) (bbody br'))) brs brs' -> P pb Γ (tCase indn p c brs) (tCase indn p' c' brs')) -> - (forall (pb : conv_pb) (Γ : context) + (forall (pb : conv_pb) (Γ : context) (p : projection) (c c' : term), cumulSpec0 Σ Γ Conv c c' -> P Conv Γ c c' -> P pb Γ (tProj p c) (tProj p c')) -> - (forall (pb : conv_pb) (Γ : context) + (forall (pb : conv_pb) (Γ : context) (mfix : mfixpoint term) (mfix' : list (def term)) (idx : nat), All2 (fun x y : def term => - ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) × + ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) × P Conv Γ (dtype x) (dtype y) × cumulSpec0 Σ (Γ,,, fix_context mfix) Conv - (dbody x) (dbody y)) × + (dbody x) (dbody y)) × P Conv (Γ,,, fix_context mfix) (dbody x) (dbody y) × rarg x = rarg y) * eq_binder_annot (dname x) (dname y)) mfix mfix' -> P pb Γ (tFix mfix idx) (tFix mfix' idx)) -> - (forall (pb : conv_pb) (Γ : context) + (forall (pb : conv_pb) (Γ : context) (mfix : mfixpoint term) (mfix' : list (def term)) (idx : nat), All2 (fun x y : def term => - ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) × + ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) × P Conv Γ (dtype x) (dtype y) × cumulSpec0 Σ (Γ,,, fix_context mfix) Conv - (dbody x) (dbody y)) × P Conv (Γ,,, fix_context mfix) + (dbody x) (dbody y)) × P Conv (Γ,,, fix_context mfix) (dbody x) (dbody y) × rarg x = rarg y) * eq_binder_annot (dname x) (dname y)) mfix mfix' -> P pb Γ (tCoFix mfix idx) (tCoFix mfix' idx)) -> - + (* cumulativity rules *) - - (forall (pb : conv_pb) + + (forall (pb : conv_pb) (Γ : context) (i : inductive) (u u' : list Level.t) - (args args' : list term), + (args args' : list term), R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (IndRef i) #|args| u u' -> All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Conv Γ)) args args' -> P pb Γ (mkApps (tInd i u) args) (mkApps (tInd i u') args')) -> - (forall (pb : conv_pb) - (Γ : context) (i : inductive) (k : nat) - (u u' : list Level.t) (args args' : list term), + (forall (pb : conv_pb) + (Γ : context) (i : inductive) (k : nat) + (u u' : list Level.t) (args args' : list term), R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (ConstructRef i k) #|args| u u' -> All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Conv Γ)) args args' -> P pb Γ (mkApps (tConstruct i k u) args) (mkApps (tConstruct i k u') args')) -> - (forall (pb : conv_pb) + (forall (pb : conv_pb) (Γ : context) (s s' : Universe.t), compare_universe pb Σ s s' -> P pb Γ (tSort s) (tSort s')) -> - (forall (pb : conv_pb) + (forall (pb : conv_pb) (Γ : context) (c : kername) (u u' : list Level.t), R_universe_instance (compare_universe Conv Σ) u u' -> P pb Γ (tConst c u) (tConst c u') ) -> @@ -404,50 +404,50 @@ Proof. move aux at top. destruct 1. - eapply X8; eauto. - - eapply X9; eauto. - - eapply X10; eauto. + - eapply X9; eauto. + - eapply X10; eauto. - eapply X20; eauto. clear -a aux. revert args args' a. fix aux' 3; destruct 1; constructor; auto. - eapply X21; eauto. clear -a aux. revert args args' a. fix aux' 3; destruct 1; constructor; auto. - - eapply X22; eauto. - - eapply X23; eauto. + - eapply X22; eauto. + - eapply X23; eauto. - eapply X11. revert args args' a. fix aux' 3; destruct 1; constructor; auto. - eapply X12; eauto. - - eapply X13; eauto. - - eapply X14; eauto. - - eapply X15; eauto. - - eapply X16 ; eauto. + - eapply X13; eauto. + - eapply X14; eauto. + - eapply X15; eauto. + - eapply X16 ; eauto. + unfold cumul_predicate in *. destruct c0 as [c0 [cuniv [ccontext creturn]]]. repeat split ; eauto. * revert c0. generalize (pparams p), (pparams p'). fix aux' 3; destruct 1; constructor; auto. + revert brs brs' a. fix aux' 3; destruct 1; constructor; intuition auto. - - eapply X17 ; eauto. - - eapply X18 ; eauto. - revert a. + - eapply X17 ; eauto. + - eapply X18 ; eauto. + revert a. set (mfixAbs := mfix). unfold mfixAbs at 2 5. clearbody mfixAbs. revert mfix mfix'. - fix aux' 3; destruct 1; constructor. + fix aux' 3; destruct 1; constructor. + intuition auto. + auto. - - eapply X19 ; eauto. - revert a. + - eapply X19 ; eauto. + revert a. set (mfixAbs := mfix). unfold mfixAbs at 2 5. clearbody mfixAbs. revert mfix mfix'. - fix aux' 3; destruct 1; constructor. + fix aux' 3; destruct 1; constructor. + intuition auto. + auto. - eapply X. - eapply X0. - - eapply X1; eauto. + - eapply X1; eauto. - eapply X2; eauto. - eapply X3; eauto. - eapply X4; eauto. @@ -519,24 +519,24 @@ Lemma convSpec0_ind_all : (* reflexivity *) (forall (Γ : context) (t : term), P Γ t t) -> - + (* congruence rules *) (forall (Γ : context) (ev : nat) (l l' : list term), All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Γ)) l l' -> P Γ (tEvar ev l) (tEvar ev l')) -> - (forall (Γ : context) (t t' u u' : term), + (forall (Γ : context) (t t' u u' : term), cumulSpec0 Σ Γ Conv t t' -> P Γ t t' -> cumulSpec0 Σ Γ Conv u u' -> P Γ u u' -> P Γ (tApp t u) (tApp t' u')) -> (forall (Γ : context) (na na' : aname) (ty ty' t t' : term), - eq_binder_annot na na' -> - cumulSpec0 Σ Γ Conv ty ty' -> P Γ ty ty' -> - cumulSpec0 Σ (Γ ,, vass na ty) Conv t t' -> P (Γ ,, vass na ty) t t' -> + eq_binder_annot na na' -> + cumulSpec0 Σ Γ Conv ty ty' -> P Γ ty ty' -> + cumulSpec0 Σ (Γ ,, vass na ty) Conv t t' -> P (Γ ,, vass na ty) t t' -> P Γ (tLambda na ty t) (tLambda na' ty' t')) -> - (forall (Γ : context) (na na' : binder_annot name) (a a' b b' : term), + (forall (Γ : context) (na na' : binder_annot name) (a a' b b' : term), eq_binder_annot na na' -> cumulSpec0 Σ Γ Conv a a' -> P Γ a a' -> cumulSpec0 Σ (Γ,, vass na a) Conv b b' -> P (Γ,, vass na a) b b' -> @@ -550,67 +550,67 @@ Lemma convSpec0_ind_all : (forall (Γ : context) (indn : case_info) (p p' : predicate term) (c c' : term) (brs brs' : list (branch term)), - cumul_predicate (fun Γ t u => cumulSpec0 Σ Γ Conv t u * P Γ t u) Γ (compare_universe Conv Σ) p p' -> + cumul_predicate (fun Γ t u => cumulSpec0 Σ Γ Conv t u * P Γ t u) Γ (compare_universe Conv Σ) p p' -> cumulSpec0 Σ Γ Conv c c' -> P Γ c c' -> All2 (Trel_conj (fun br br' : branch term => eq_context_gen eq eq (bcontext br) (bcontext br') * cumulSpec0 Σ (Γ,,, inst_case_branch_context p br) Conv - (bbody br) (bbody br')) - (fun br br' => P (Γ,,, inst_case_branch_context p br) (bbody br) (bbody br'))) brs brs' -> + (bbody br) (bbody br')) + (fun br br' => P (Γ,,, inst_case_branch_context p br) (bbody br) (bbody br'))) brs brs' -> P Γ (tCase indn p c brs) (tCase indn p' c' brs')) -> - (forall (Γ : context) + (forall (Γ : context) (p : projection) (c c' : term), cumulSpec0 Σ Γ Conv c c' -> P Γ c c' -> P Γ (tProj p c) (tProj p c')) -> - (forall (Γ : context) + (forall (Γ : context) (mfix : mfixpoint term) (mfix' : list (def term)) (idx : nat), All2 (fun x y : def term => - ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) × + ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) × P Γ (dtype x) (dtype y) × cumulSpec0 Σ (Γ,,, fix_context mfix) Conv - (dbody x) (dbody y)) × P (Γ,,, fix_context mfix) + (dbody x) (dbody y)) × P (Γ,,, fix_context mfix) (dbody x) (dbody y) × rarg x = rarg y) * eq_binder_annot (dname x) (dname y)) mfix mfix' -> P Γ (tFix mfix idx) (tFix mfix' idx)) -> - (forall (Γ : context) + (forall (Γ : context) (mfix : mfixpoint term) (mfix' : list (def term)) (idx : nat), All2 (fun x y : def term => - ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) × + ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) × P Γ (dtype x) (dtype y) × cumulSpec0 Σ (Γ,,, fix_context mfix) Conv - (dbody x) (dbody y)) × P (Γ,,, fix_context mfix) + (dbody x) (dbody y)) × P (Γ,,, fix_context mfix) (dbody x) (dbody y) × rarg x = rarg y) * eq_binder_annot (dname x) (dname y)) mfix mfix' -> P Γ (tCoFix mfix idx) (tCoFix mfix' idx)) -> - + (* cumulativiity rules *) - - (forall + + (forall (Γ : context) (i : inductive) (u u' : list Level.t) - (args args' : list term), + (args args' : list term), R_global_instance Σ (eq_universe Σ) (eq_universe Σ) (IndRef i) #|args| u u' -> All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Γ)) args args' -> P Γ (mkApps (tInd i u) args) (mkApps (tInd i u') args')) -> - (forall - (Γ : context) (i : inductive) (k : nat) - (u u' : list Level.t) (args args' : list term), + (forall + (Γ : context) (i : inductive) (k : nat) + (u u' : list Level.t) (args args' : list term), R_global_instance Σ (eq_universe Σ) (eq_universe Σ) (ConstructRef i k) #|args| u u' -> All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Γ)) args args' -> P Γ (mkApps (tConstruct i k u) args) (mkApps (tConstruct i k u') args')) -> - (forall + (forall (Γ : context) (s s' : Universe.t), eq_universe Σ s s' -> P Γ (tSort s) (tSort s')) -> - (forall + (forall (Γ : context) (c : kername) (u u' : list Level.t), R_universe_instance (eq_universe Σ) u u' -> P Γ (tConst c u) (tConst c u') ) -> @@ -621,50 +621,50 @@ Proof. move aux at top. destruct 1. - eapply X8; eauto. - - eapply X9; eauto. - - eapply X10; eauto. + - eapply X9; eauto. + - eapply X10; eauto. - eapply X20; eauto. clear -a aux. revert args args' a. fix aux' 3; destruct 1; constructor; auto. - eapply X21; eauto. clear -a aux. revert args args' a. fix aux' 3; destruct 1; constructor; auto. - - eapply X22; eauto. - - eapply X23; eauto. + - eapply X22; eauto. + - eapply X23; eauto. - eapply X11. revert args args' a. fix aux' 3; destruct 1; constructor; auto. - eapply X12; eauto. - - eapply X13; eauto. - - eapply X14; eauto. - - eapply X15; eauto. - - eapply X16 ; eauto. + - eapply X13; eauto. + - eapply X14; eauto. + - eapply X15; eauto. + - eapply X16 ; eauto. + unfold cumul_predicate in *. destruct c0 as [c0 [cuniv [ccontext creturn]]]. repeat split ; eauto. * revert c0. generalize (pparams p), (pparams p'). fix aux' 3; destruct 1; constructor; auto. + revert brs brs' a. fix aux' 3; destruct 1; constructor; intuition auto. - - eapply X17 ; eauto. - - eapply X18 ; eauto. - revert a. + - eapply X17 ; eauto. + - eapply X18 ; eauto. + revert a. set (mfixAbs := mfix). unfold mfixAbs at 2 5. clearbody mfixAbs. revert mfix mfix'. - fix aux' 3; destruct 1; constructor. + fix aux' 3; destruct 1; constructor. + intuition auto. + auto. - - eapply X19 ; eauto. - revert a. + - eapply X19 ; eauto. + revert a. set (mfixAbs := mfix). unfold mfixAbs at 2 5. clearbody mfixAbs. revert mfix mfix'. - fix aux' 3; destruct 1; constructor. + fix aux' 3; destruct 1; constructor. + intuition auto. + auto. - eapply X. - eapply X0. - - eapply X1; eauto. + - eapply X1; eauto. - eapply X2; eauto. - eapply X3; eauto. - eapply X4; eauto. diff --git a/pcuic/theories/PCUICElimination.v b/pcuic/theories/PCUICElimination.v index aac7e085b..88fc6753c 100644 --- a/pcuic/theories/PCUICElimination.v +++ b/pcuic/theories/PCUICElimination.v @@ -3,11 +3,11 @@ From Coq Require Import ssrbool. From MetaCoq.Template Require Import config utils Universes. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICCasesContexts PCUICTyping PCUICGlobalEnv - PCUICLiftSubst PCUICInductives PCUICGeneration PCUICSpine + PCUICLiftSubst PCUICInductives PCUICGeneration PCUICSpine PCUICWeakeningEnv PCUICWeakeningEnvTyp PCUICSubstitution PCUICUnivSubst PCUICUnivSubstitutionConv PCUICUnivSubstitutionTyp PCUICConversion PCUICCumulativity PCUICConfluence PCUICContexts - PCUICSR PCUICInversion PCUICValidity PCUICSafeLemmata + PCUICSR PCUICInversion PCUICValidity PCUICSafeLemmata PCUICContextConversion PCUICContextConversionTyp PCUICCumulProp PCUICWellScopedCumulativity PCUICArities. From MetaCoq.PCUIC Require Import PCUICInductiveInversion PCUICOnFreeVars PCUICEquality. @@ -18,7 +18,7 @@ Require Import ssreflect. Implicit Types (cf : checker_flags) (Σ : global_env_ext). -Definition Is_proof `{cf : checker_flags} Σ Γ t := ∑ T u, Σ ;;; Γ |- t : T × Σ ;;; Γ |- T : tSort u × +Definition Is_proof `{cf : checker_flags} Σ Γ t := ∑ T u, Σ ;;; Γ |- t : T × Σ ;;; Γ |- T : tSort u × (Universe.is_prop u || Universe.is_sprop u). Definition SingletonProp `{cf : checker_flags} (Σ : global_env_ext) (ind : inductive) := @@ -58,17 +58,17 @@ Lemma typing_spine_case_predicate {cf: checker_flags} {Σ : global_env_ext} {wf declared_inductive Σ ci mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> wf_universe Σ ps -> - spine_subst Σ Γ params (List.rev params) + spine_subst Σ Γ params (List.rev params) (smash_context [] (subst_instance u (ind_params mdecl))) -> - spine_subst Σ Γ indices (List.rev indices) + spine_subst Σ Γ indices (List.rev indices) (subst_context_let_expand (List.rev params) (subst_instance u (ind_params mdecl)) (smash_context [] (subst_instance u (ind_indices idecl)))) -> Σ ;;; Γ |- c : mkApps (tInd ci u) (params ++ indices) -> typing_spine Σ Γ (it_mkProd_or_LetIn - (pre_case_predicate_context_gen ci mdecl idecl params u) - (tSort ps)) + (pre_case_predicate_context_gen ci mdecl idecl params u) + (tSort ps)) (indices ++ [c]) (tSort ps). Proof. intros. @@ -84,10 +84,10 @@ Lemma pre_case_predicate_context_gen_eq {cf: checker_flags} {Σ : global_env_ext declared_inductive Σ ci mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) (puinst p) -> wf_universe Σ ps -> - spine_subst Σ Γ (pparams p) (List.rev (pparams p)) + spine_subst Σ Γ (pparams p) (List.rev (pparams p)) (smash_context [] (ind_params mdecl)@[puinst p]) -> - Σ ⊢ Γ ,,, pre_case_predicate_context_gen ci mdecl idecl (pparams p) (puinst p) = - Γ ,,, case_predicate_context' ci mdecl idecl p. + Σ ⊢ Γ ,,, pre_case_predicate_context_gen ci mdecl idecl (pparams p) (puinst p) = + Γ ,,, case_predicate_context' ci mdecl idecl p. Proof. intros wf decli cu wfps sp. eapply alpha_eq_context_ws_cumul_ctx_pb. @@ -96,7 +96,7 @@ Proof. rewrite /case_predicate_context' /=. cbn. rewrite subst_context_snoc; len. constructor. constructor; cbn. reflexivity. - rewrite subst_instance_mkApps subst_mkApps. f_equal. cbn. + rewrite subst_instance_mkApps subst_mkApps. f_equal. cbn. now rewrite [subst_instance_instance _ _](subst_instance_id_mdecl _ _ _ cu). rewrite [to_extended_list _]to_extended_list_k_app; len; rewrite !map_app. f_equal. @@ -117,7 +117,7 @@ Proof. eapply isType_wf_local in X. fvs. Qed. -Lemma elim_restriction_works_kelim1 {cf : checker_flags} {Σ : global_env_ext} +Lemma elim_restriction_works_kelim1 {cf : checker_flags} {Σ : global_env_ext} {Γ T ci p c brs mdecl idecl} : check_univs -> wf_ext Σ -> @@ -151,7 +151,7 @@ Proof. forward X1. apply (wf_predicate_length_pars wf_pred). simpl in X1. destruct X1 as [sppars [spargs cu']]. assert (eqctx' : All2 (PCUICEquality.compare_decls eq eq) - (Γ,,, case_predicate_context' ci mdecl idecl p) + (Γ,,, case_predicate_context' ci mdecl idecl p) (Γ,,, predctx)). { eapply All2_app. 2:eapply All2_refl; reflexivity. eapply case_predicate_context_alpha => //; tea. @@ -162,7 +162,7 @@ Proof. * symmetry. eapply alpha_eq_context_ws_cumul_ctx_pb => //; fvs. now symmetry. * eapply pre_case_predicate_context_gen_eq; tea. pcuic. now eapply PCUICWfUniverses.typing_wf_universe in pret_ty. } - unshelve epose proof (typing_spine_case_predicate (ps:=ps) _ H cons _ sppars). 1-2:shelve. + unshelve epose proof (typing_spine_case_predicate (ps:=ps) _ H cons _ sppars). 1-2:shelve. * pcuic. * now eapply PCUICWfUniverses.typing_wf_universe in pret_ty. * rewrite -smash_context_subst_context_let_expand in X2. @@ -178,18 +178,18 @@ Proof. Qed. Lemma elim_sort_intype {cf:checker_flags} Σ mdecl ind idecl ind_indices ind_sort cdecls : - Universe.is_prop ind_sort -> + Universe.is_prop ind_sort -> elim_sort_prop_ind cdecls = IntoAny -> on_constructors cumulSpec0 (lift_typing typing) - (Σ, ind_universes mdecl) mdecl + (Σ, ind_universes mdecl) mdecl (inductive_ind ind) idecl ind_indices (ind_ctors idecl) cdecls -> - (#|ind_ctors idecl| = 0) + - (∑ cdecl cdecl_sorts, - (ind_ctors idecl = [cdecl]) * - (cdecls = [cdecl_sorts]) * + (#|ind_ctors idecl| = 0) + + (∑ cdecl cdecl_sorts, + (ind_ctors idecl = [cdecl]) * + (cdecls = [cdecl_sorts]) * (Forall is_propositional cdecl_sorts) * - (on_constructor cumulSpec0 (lift_typing typing) (Σ, ind_universes mdecl) mdecl + (on_constructor cumulSpec0 (lift_typing typing) (Σ, ind_universes mdecl) mdecl (inductive_ind ind) idecl ind_indices cdecl cdecl_sorts))%type. Proof. intros uf lein onc. @@ -204,9 +204,9 @@ Proof. - discriminate. Qed. -Lemma typing_spine_it_mkProd_or_LetIn_full_inv {cf:checker_flags} Σ Γ Δ s args s' : +Lemma typing_spine_it_mkProd_or_LetIn_full_inv {cf:checker_flags} Σ Γ Δ s args s' : wf Σ.1 -> - typing_spine Σ Γ (it_mkProd_or_LetIn Δ (tSort s)) args (tSort s') -> + typing_spine Σ Γ (it_mkProd_or_LetIn Δ (tSort s)) args (tSort s') -> leq_universe (global_ext_constraints Σ) s s'. Proof. intros wfΣ. @@ -304,7 +304,7 @@ Lemma isType_ws_cumul_ctx_pb {cf Σ Γ Δ T} {wfΣ : wf Σ}: Proof. intros HT wf eq. apply infer_sort_impl with id HT; intros Hs. - eapply closed_context_conversion; tea. + eapply closed_context_conversion; tea. Qed. Lemma typing_spine_proofs {cf:checker_flags} Σ Γ Δ ind u args' args T' s : @@ -315,12 +315,12 @@ Lemma typing_spine_proofs {cf:checker_flags} Σ Γ Δ ind u args' args T' s : ((All_local_assum (fun Γ' t => (∑ s, (Σ ;;; Γ ,,, Γ' |- t : tSort s) * is_propositional s)%type) Δ -> ∥ All (Is_proof Σ Γ) args ∥) * - (forall mdecl idecl + (forall mdecl idecl (Hdecl : declared_inductive Σ.1 ind mdecl idecl), consistent_instance_ext Σ (ind_universes mdecl) u -> - ((is_propositional s -> s = subst_instance_univ u idecl.(ind_sort)) /\ + ((is_propositional s -> s = subst_instance_univ u idecl.(ind_sort)) /\ (prop_sub_type = false -> - is_propositional (subst_instance_univ u idecl.(ind_sort)) -> + is_propositional (subst_instance_univ u idecl.(ind_sort)) -> s = subst_instance_univ u idecl.(ind_sort)))))%type. Proof. intros checku wfΣ Ht. @@ -357,7 +357,7 @@ Proof. now destruct (ind_sort idecl). now destruct (ind_sort idecl). now eapply declared_inductive_valid_type. - + * now eapply invert_cumul_ind_prod in e. - destruct d as [na [b|] ty]. @@ -430,7 +430,7 @@ Proof. 2:{ destruct s0 as [s' [Hs' _]]. exists s'; auto. } 2:now symmetry. destruct H as [H _]. - forward H. { + forward H. { clear -wfΣ prs tyt. eapply All_local_assum_subst; eauto. simpl. intros. @@ -447,9 +447,9 @@ Qed. Lemma check_ind_sorts_is_propositional {cf:checker_flags} (Σ : global_env_ext) mdecl idecl ind (onib : on_ind_body cumulSpec0 (lift_typing typing) (Σ.1, ind_universes mdecl) - (inductive_mind ind) mdecl (inductive_ind ind) idecl) : + (inductive_mind ind) mdecl (inductive_ind ind) idecl) : (ind_kelim idecl <> IntoPropSProp /\ ind_kelim idecl <> IntoSProp) -> - is_propositional (ind_sort idecl) -> + is_propositional (ind_sort idecl) -> check_ind_sorts (lift_typing typing) (Σ.1, ind_universes mdecl) (PCUICEnvironment.ind_params mdecl) (PCUICEnvironment.ind_kelim idecl) (ind_indices idecl) (ind_cunivs onib) (ind_sort idecl) -> @@ -471,9 +471,9 @@ Proof. unfold is_propositional in isp. now rewrite isp' issp in isp. Qed. - -Lemma sorts_local_ctx_All_local_assum_impl {cf:checker_flags} Σ - (P : context -> context -> term -> Type) {Γ Δ cs} : + +Lemma sorts_local_ctx_All_local_assum_impl {cf:checker_flags} Σ + (P : context -> context -> term -> Type) {Γ Δ cs} : (forall Γ' t s, In s cs -> Σ ;;; Γ ,,, Γ' |- t : tSort s -> P Γ Γ' t) -> sorts_local_ctx (lift_typing typing) Σ Γ Δ cs -> All_local_assum (P Γ) Δ. @@ -488,8 +488,8 @@ Proof. eapply H. left; eauto. eauto. Qed. -Lemma In_map {A B} (f : A -> B) (l : list A) x : - In x (map f l) -> +Lemma In_map {A B} (f : A -> B) (l : list A) x : + In x (map f l) -> exists y, In y l /\ x = f y. Proof. induction l; simpl; auto. @@ -499,7 +499,7 @@ Proof. Qed. (* We prove that if the (partial) constructor application's type lands in Prop - then the inductive type is in Prop and hence the constructor's sort is + then the inductive type is in Prop and hence the constructor's sort is Prop. Finally, all its arguments are in Prop because we additionally know that elimination to any type is allowed. *) @@ -544,8 +544,8 @@ Proof. eapply typing_spine_proofs in sp; eauto. destruct sp. specialize (a _ _ declc cu) as [a a']. - specialize (a hp). - + specialize (a hp). + pose proof (onc.(on_cargs)). pose proof (onib.(ind_sorts)). assert (Universe.is_prop (ind_sort idecl) || Universe.is_sprop (ind_sort idecl)). @@ -553,7 +553,7 @@ Proof. apply check_ind_sorts_is_propositional in X1 as [nctors X1]; eauto. assert(#|ind_cunivs onib| = #|ind_ctors idecl|). clear X. clear -onib. pose proof (onib.(onConstructors)). - eapply All2_length in X. now rewrite X. + eapply All2_length in X. now rewrite X. rewrite H0 in nctors; split; auto. eapply nth_error_all in X1; eauto. simpl in X1. @@ -562,8 +562,8 @@ Proof. rewrite subst_instance_app in X0. eapply weaken_sorts_local_ctx in X0; eauto. eapply (subst_sorts_local_ctx _ _) in X0; eauto. - 3:{ eapply subslet_app. - 2:{ eapply weaken_subslet; auto. eapply PCUICArities.subslet_inds; eauto. } + 3:{ eapply subslet_app. + 2:{ eapply weaken_subslet; auto. eapply PCUICArities.subslet_inds; eauto. } eapply sub. } 2:{ eapply PCUICWeakeningTyp.weaken_wf_local; auto. edestruct (PCUICInductiveInversion.on_constructor_inst declc); eauto. @@ -575,8 +575,8 @@ Proof. rewrite subst_app_context in X0. rewrite -(PCUICContextSubst.context_subst_length sub) in X0. autorewrite with len in X0. - eapply (sorts_local_ctx_All_local_assum_impl Σ - (fun Γ Γ' t => + eapply (sorts_local_ctx_All_local_assum_impl Σ + (fun Γ Γ' t => ∑ s0 : Universe.t, Σ;;; Γ ,,, Γ' |- t : tSort s0 × is_propositional s0)). 2:eauto. intros. exists s0. intuition auto. @@ -584,7 +584,7 @@ Proof. rewrite is_propositional_subst_instance. eapply All_In in X1; eauto. sq. apply X1. - + * intros _ sp. rewrite List.skipn_all2. lia. split; [|repeat constructor]. @@ -602,7 +602,7 @@ Proof. subst tycs. rewrite -(is_propositional_subst_instance u) //. * now eapply declared_constructor_valid_ty. Qed. - + Lemma elim_restriction_works_kelim `{cf : checker_flags} (Σ : global_env_ext) ind mind idecl : check_univs -> wf_ext Σ -> @@ -619,7 +619,7 @@ Proof. now eapply weakening_env_declared_inductive; tc. Qed. -Lemma elim_restriction_works `{cf : checker_flags} (Σ : global_env_ext) Γ T (ci : case_info) p c brs mind idecl : +Lemma elim_restriction_works `{cf : checker_flags} (Σ : global_env_ext) Γ T (ci : case_info) p c brs mind idecl : check_univs -> wf_ext Σ -> declared_inductive (fst Σ) ci mind idecl -> @@ -681,7 +681,7 @@ Lemma leq_term_prop_sorted_l {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> Universe.is_prop u -> + Σ;;; Γ |- v' : tSort u' -> Universe.is_prop u -> leq_universe (global_ext_constraints Σ) u' u. Proof using Hcf Hcf'. intros wfΣ leq hv hv' isp. @@ -695,7 +695,7 @@ Lemma leq_term_prop_sorted_r {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> Universe.is_prop u' -> + Σ;;; Γ |- v' : tSort u' -> Universe.is_prop u' -> leq_universe (global_ext_constraints Σ) u u'. Proof using Hcf Hcf'. intros wfΣ leq hv hv' isp. @@ -708,7 +708,7 @@ Lemma leq_term_sprop_sorted_l {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> Universe.is_sprop u -> + Σ;;; Γ |- v' : tSort u' -> Universe.is_sprop u -> leq_universe (global_ext_constraints Σ) u' u. Proof using Hcf Hcf'. intros wfΣ leq hv hv' isp. @@ -722,7 +722,7 @@ Lemma leq_term_propositional_sorted_l {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> is_propositional u -> + Σ;;; Γ |- v' : tSort u' -> is_propositional u -> leq_universe (global_ext_constraints Σ) u' u. Proof using Hcf Hcf'. intros wfΣ leq hv hv' isp. @@ -735,7 +735,7 @@ Lemma leq_term_sprop_sorted_r {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> Universe.is_sprop u' -> + Σ;;; Γ |- v' : tSort u' -> Universe.is_sprop u' -> leq_universe (global_ext_constraints Σ) u u'. Proof using Hcf Hcf'. intros wfΣ leq hv hv' isp. @@ -747,7 +747,7 @@ Qed. Lemma cumul_prop_inv (Σ : global_env_ext) Γ A B u u' : wf_ext Σ -> Universe.is_prop u -> - (((Σ ;;; Γ |- A : tSort u) * (Σ ;;; Γ |- B : tSort u')) + + (((Σ ;;; Γ |- A : tSort u) * (Σ ;;; Γ |- B : tSort u')) + ((Σ ;;; Γ |- B : tSort u) * (Σ ;;; Γ |- A : tSort u')))%type -> Σ ;;; Γ |- A <= B -> ((Σ ;;; Γ |- A : tSort u) * (Σ ;;; Γ |- B : tSort u))%type. @@ -774,7 +774,7 @@ Qed. Lemma cumul_sprop_inv (Σ : global_env_ext) Γ A B u u' : wf_ext Σ -> Universe.is_sprop u -> - (((Σ ;;; Γ |- A : tSort u) * (Σ ;;; Γ |- B : tSort u')) + + (((Σ ;;; Γ |- A : tSort u) * (Σ ;;; Γ |- B : tSort u')) + ((Σ ;;; Γ |- B : tSort u) * (Σ ;;; Γ |- A : tSort u')))%type -> Σ ;;; Γ |- A <= B -> ((Σ ;;; Γ |- A : tSort u) * (Σ ;;; Γ |- B : tSort u))%type. @@ -797,10 +797,10 @@ Proof using Hcf Hcf'. eapply PCUICArities.isType_Sort. 1: now destruct u. 1: now pcuic. - now eapply cumul_Sort. + now eapply cumul_Sort. Qed. -Lemma unique_sorting_equality_prop_l {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_prop_l {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> @@ -816,7 +816,7 @@ Proof using Hcf Hcf'. eapply leq_universe_prop_r; tea; eauto with pcuic. Qed. -Lemma unique_sorting_equality_prop_r {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_prop_r {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> @@ -832,7 +832,7 @@ Proof using Hcf Hcf'. eapply leq_universe_prop_r; tea; eauto with pcuic. Qed. -Lemma unique_sorting_equality_prop {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_prop {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> @@ -846,7 +846,7 @@ Proof using Hcf Hcf'. now eapply unique_sorting_equality_prop_r; tea. Qed. -Lemma unique_sorting_equality_sprop_l {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_sprop_l {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> @@ -862,7 +862,7 @@ Proof using Hcf Hcf'. eapply leq_universe_sprop_r; tea; eauto with pcuic. Qed. -Lemma unique_sorting_equality_sprop_r {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_sprop_r {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> @@ -878,7 +878,7 @@ Proof using Hcf Hcf'. eapply leq_universe_sprop_r; tea; eauto with pcuic. Qed. -Lemma unique_sorting_equality_sprop {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_sprop {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> @@ -892,7 +892,7 @@ Proof using Hcf Hcf'. now eapply unique_sorting_equality_sprop_r; tea. Qed. -Lemma unique_sorting_equality_propositional {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_propositional {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> diff --git a/pcuic/theories/PCUICEquality.v b/pcuic/theories/PCUICEquality.v index dc1e8f158..5d698ac7f 100644 --- a/pcuic/theories/PCUICEquality.v +++ b/pcuic/theories/PCUICEquality.v @@ -24,7 +24,7 @@ Definition R_universe_instance R := (** Cumulative inductive types: - To simplify the development, we allow the variance list to not exactly + To simplify the development, we allow the variance list to not exactly match the instances, so as to keep syntactic ws_cumul_pb an equivalence relation even on ill-formed terms. It corresponds to the right notion on well-formed terms. *) @@ -40,7 +40,7 @@ Fixpoint R_universe_instance_variance Re Rle v u u' := match u, u' return Prop with | u :: us, u' :: us' => match v with - | [] => R_universe_instance_variance Re Rle v us us' + | [] => R_universe_instance_variance Re Rle v us us' (* Missing variance stands for irrelevance, we still check that the instances have the same length. *) | v :: vs => R_universe_variance Re Rle v u u' /\ @@ -54,7 +54,7 @@ Definition global_variance Σ gr napp := match gr with | IndRef ind => match lookup_inductive Σ ind with - | Some (mdecl, idecl) => + | Some (mdecl, idecl) => match destArity [] idecl.(ind_type) with | Some (ctx, _) => if (context_assumptions ctx) <=? napp then mdecl.(ind_variance) else None @@ -66,7 +66,7 @@ Definition global_variance Σ gr napp := match lookup_constructor Σ ind k with | Some (mdecl, idecl, cdecl) => if (cdecl.(cstr_arity) + mdecl.(ind_npars))%nat <=? napp then - (** Fully applied constructors are always compared at the same supertype, + (** Fully applied constructors are always compared at the same supertype, which implies that no universe ws_cumul_pb needs to be checked here. *) Some [] else None @@ -76,7 +76,7 @@ Definition global_variance Σ gr napp := end. Definition R_opt_variance Re Rle v := - match v with + match v with | Some v => R_universe_instance_variance Re Rle v | None => R_universe_instance Re end. @@ -86,7 +86,7 @@ Definition R_global_instance Σ Re Rle gr napp := Definition R_ind_universes {cf:checker_flags} (Σ : global_env_ext) ind n i i' := R_global_instance Σ (eq_universe (global_ext_constraints Σ)) - (leq_universe (global_ext_constraints Σ)) (IndRef ind) n i i'. + (leq_universe (global_ext_constraints Σ)) (IndRef ind) n i i'. Lemma R_universe_instance_impl R R' : RelationClasses.subrelation R R' -> @@ -116,7 +116,7 @@ Section compare_decls. | compare_vdef {na b T na' b' T'} : eq_binder_annot na na' -> eq_term b b' -> - leq_term T T' -> + leq_term T T' -> compare_decls (vdef na b T) (vdef na' b' T'). Derive Signature NoConfusion for compare_decls. @@ -182,10 +182,10 @@ Definition bcompare_decls (eq_term leq_term : term -> term -> bool) (d d' : cont end. #[global] -Polymorphic Instance compare_decl_refl eq_term leq_term : - CRelationClasses.Reflexive eq_term -> - CRelationClasses.Reflexive leq_term -> - CRelationClasses.Reflexive (compare_decls eq_term leq_term). +Polymorphic Instance compare_decl_refl eq_term leq_term : + CRelationClasses.Reflexive eq_term -> + CRelationClasses.Reflexive leq_term -> + CRelationClasses.Reflexive (compare_decls eq_term leq_term). Proof. intros heq hle d. destruct d as [na [b|] ty]; constructor; auto; reflexivity. @@ -193,18 +193,18 @@ Qed. #[global] Polymorphic Instance compare_decl_sym eq_term leq_term : - CRelationClasses.Symmetric eq_term -> - CRelationClasses.Symmetric leq_term -> - CRelationClasses.Symmetric (compare_decls eq_term leq_term). + CRelationClasses.Symmetric eq_term -> + CRelationClasses.Symmetric leq_term -> + CRelationClasses.Symmetric (compare_decls eq_term leq_term). Proof. intros heq hle d d' []; constructor; auto; now symmetry. Qed. #[global] Polymorphic Instance compare_decl_trans eq_term leq_term : - CRelationClasses.Transitive eq_term -> - CRelationClasses.Transitive leq_term -> - CRelationClasses.Transitive (compare_decls eq_term leq_term). + CRelationClasses.Transitive eq_term -> + CRelationClasses.Transitive leq_term -> + CRelationClasses.Transitive (compare_decls eq_term leq_term). Proof. intros hle hre x y z h h'; depelim h; depelim h'; constructor; auto; etransitivity; eauto. @@ -229,36 +229,36 @@ Proof. Qed. #[global] -Polymorphic Instance eq_context_refl eq_term leq_term : - CRelationClasses.Reflexive eq_term -> - CRelationClasses.Reflexive leq_term -> - CRelationClasses.Reflexive (eq_context_gen eq_term leq_term). +Polymorphic Instance eq_context_refl eq_term leq_term : + CRelationClasses.Reflexive eq_term -> + CRelationClasses.Reflexive leq_term -> + CRelationClasses.Reflexive (eq_context_gen eq_term leq_term). Proof. intros heq hle x. eapply All2_fold_refl. - intros. reflexivity. + intros. reflexivity. Qed. #[global] -Polymorphic Instance eq_context_sym eq_term leq_term : - CRelationClasses.Symmetric eq_term -> - CRelationClasses.Symmetric leq_term -> - CRelationClasses.Symmetric (eq_context_gen eq_term leq_term). +Polymorphic Instance eq_context_sym eq_term leq_term : + CRelationClasses.Symmetric eq_term -> + CRelationClasses.Symmetric leq_term -> + CRelationClasses.Symmetric (eq_context_gen eq_term leq_term). Proof. intros heq hle x. eapply All2_fold_sym. - intros. now symmetry. + intros. now symmetry. Qed. #[global] -Polymorphic Instance eq_context_trans eq_term leq_term : - CRelationClasses.Transitive eq_term -> - CRelationClasses.Transitive leq_term -> - CRelationClasses.Transitive (eq_context_gen eq_term leq_term). +Polymorphic Instance eq_context_trans eq_term leq_term : + CRelationClasses.Transitive eq_term -> + CRelationClasses.Transitive leq_term -> + CRelationClasses.Transitive (eq_context_gen eq_term leq_term). Proof. intros hr x y z. eapply All2_fold_trans; intros. - now transitivity y0. + now transitivity y0. Qed. Definition eq_predicate (eq_term : term -> term -> Type) Re p p' := @@ -272,7 +272,7 @@ Definition eq_predicate (eq_term : term -> term -> Type) Re p p' := (** ws_cumul_pb is indexed by a natural number that counts the number of applications that surround the current term, used to implement cumulativity of inductive types - correctly (only fully applied constructors and inductives benefit from it). *) + correctly (only fully applied constructors and inductives benefit from it). *) Reserved Notation " Σ ⊢ t <==[ Rle , napp ] u" (at level 50, t, u at next level, format "Σ ⊢ t <==[ Rle , napp ] u"). @@ -359,7 +359,7 @@ Inductive eq_term_upto_univ_napp Σ (Re Rle : Universe.t -> Universe.t -> Prop) eq_binder_annot x.(dname) y.(dname) ) mfix mfix' -> Σ ⊢ tCoFix mfix idx <==[ Rle , napp ] tCoFix mfix' idx - + | eq_Prim i : eq_term_upto_univ_napp Σ Re Rle napp (tPrim i) (tPrim i) where " Σ ⊢ t <==[ Rle , napp ] u " := (eq_term_upto_univ_napp Σ _ Rle napp t u) : type_scope. @@ -369,7 +369,7 @@ Notation eq_term_upto_univ Σ Re Rle := (eq_term_upto_univ_napp Σ Re Rle 0). Definition compare_term_napp `{checker_flags} (pb : conv_pb) Σ φ napp (t u : term) := eq_term_upto_univ_napp Σ (eq_universe φ) (compare_universe pb φ) napp t u. - + Definition compare_term `{checker_flags} (pb : conv_pb) Σ φ (t u : term) := eq_term_upto_univ Σ (eq_universe φ) (compare_universe pb φ) t u. @@ -396,14 +396,14 @@ Notation leq_decl := (compare_decl Cumul). Definition compare_context `{checker_flags} pb Σ φ (Γ Δ : context) := eq_context_gen (compare_term Conv Σ φ) (compare_term pb Σ φ) Γ Δ. - + Notation eq_context := (compare_context Conv). Notation leq_context := (compare_context Cumul). -Notation eq_context_upto Σ Re Rle := +Notation eq_context_upto Σ Re Rle := (eq_context_gen (eq_term_upto_univ Σ Re Re) (eq_term_upto_univ Σ Re Rle)). -Lemma R_global_instance_refl Σ Re Rle gr napp u : +Lemma R_global_instance_refl Σ Re Rle gr napp u : RelationClasses.Reflexive Re -> RelationClasses.Reflexive Rle -> R_global_instance Σ Re Rle gr napp u u. @@ -421,12 +421,12 @@ Qed. #[global] Instance eq_binder_annot_equiv {A} : RelationClasses.Equivalence (@eq_binder_annot A A). Proof. - split. + split. - red. reflexivity. - red; now symmetry. - intros x y z; unfold eq_binder_annot. apply transitivity. -Qed. +Qed. Definition eq_binder_annot_refl {A} x : @eq_binder_annot A A x x. Proof. reflexivity. Qed. @@ -455,19 +455,19 @@ Proof. now eapply All_All2_refl, All_refl. Qed. Hint Resolve eq_binder_relevances_refl : core. #[global] -Instance R_universe_instance_refl Re : RelationClasses.Reflexive Re -> +Instance R_universe_instance_refl Re : RelationClasses.Reflexive Re -> RelationClasses.Reflexive (R_universe_instance Re). -Proof. intros tRe x. eapply Forall2_map. +Proof. intros tRe x. eapply Forall2_map. induction x; constructor; auto. Qed. #[global] -Instance R_universe_instance_sym Re : RelationClasses.Symmetric Re -> +Instance R_universe_instance_sym Re : RelationClasses.Symmetric Re -> RelationClasses.Symmetric (R_universe_instance Re). Proof. intros tRe x y. now eapply Forall2_symP. Qed. - + #[global] -Instance R_universe_instance_trans Re : RelationClasses.Transitive Re -> +Instance R_universe_instance_trans Re : RelationClasses.Transitive Re -> RelationClasses.Transitive (R_universe_instance Re). Proof. intros tRe x y z. now eapply Forall2_trans. Qed. @@ -530,7 +530,7 @@ Proof. eapply eq_term_upto_univ_refl; tc. Qed. Derive Signature for eq_term_upto_univ_napp. -Lemma R_global_instance_sym Σ Re Rle gr napp u u' : +Lemma R_global_instance_sym Σ Re Rle gr napp u u' : RelationClasses.Symmetric Re -> RelationClasses.Symmetric Rle -> R_global_instance Σ Re Rle gr napp u' u -> @@ -546,7 +546,7 @@ Proof. apply IHu; auto. - apply Forall2_symP; eauto. Qed. - + Lemma onctx_eq_ctx_sym P ctx ctx' eq_term : onctx P ctx -> (forall x, P x -> forall y, eq_term x y -> eq_term y x) -> @@ -762,7 +762,7 @@ Proof. split; tc. Qed. #[global] Polymorphic Instance leq_term_preorder {cf:checker_flags} Σ φ : PreOrder (leq_term Σ φ). -Proof. split; tc. Qed. +Proof. split; tc. Qed. #[global] Instance R_universe_instance_equiv R (hR : RelationClasses.Equivalence R) @@ -805,7 +805,7 @@ Proof. induction u in l, v |- *; destruct v, l; simpl; auto. intros [at' uv] [ta vu]. split; auto. destruct t0; simpl in *; auto. -Qed. +Qed. Lemma eq_term_upto_univ_antisym Σ Re Rle (hRe : RelationClasses.Equivalence Re) : RelationClasses.Antisymmetric _ Re Rle -> @@ -825,7 +825,7 @@ Proof. eapply eq_term_upto_univ_antisym; exact _. Qed. -Lemma global_variance_napp_mon {Σ gr napp napp' v} : +Lemma global_variance_napp_mon {Σ gr napp napp' v} : napp <= napp' -> global_variance Σ gr napp = Some v -> global_variance Σ gr napp' = Some v. @@ -961,7 +961,7 @@ Proof. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. - - inversion 1; subst; constructor. + - inversion 1; subst; constructor. (* eapply shelf bug... fixed in unifall *) eapply R_global_instance_empty_impl. 4:eauto. all:eauto. - inversion 1; subst; constructor. @@ -975,7 +975,7 @@ Proof. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. - cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. + cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. Qed. #[global] @@ -1051,7 +1051,7 @@ Lemma lift_compare_context `{checker_flags} pb Σ φ l l' n k : Proof. unfold compare_context. induction 1; rewrite -> ?lift_context_snoc0. constructor. - constructor; auto. + constructor; auto. eapply lift_compare_decls in p. now rewrite (All2_fold_length X). Qed. @@ -1091,7 +1091,7 @@ Proof. destruct h as [t' [e' h]]. rewrite e'. eapply eq_term_upto_univ_lift. - eapply eq_term_upto_univ_leq. 3:eauto. all:auto with arith. + eapply eq_term_upto_univ_leq. 3:eauto. all:auto with arith. * intros h. eapply All2_nth_error_None in h as hh ; eauto. rewrite hh. apply All2_length in hl as e. rewrite <- e. @@ -1145,7 +1145,7 @@ Qed. Lemma eq_term_eq_term_napp Σ Re Rle napp t t' : RelationClasses.subrelation Re Rle -> - eq_term_upto_univ Σ Re Rle t t' -> + eq_term_upto_univ Σ Re Rle t t' -> eq_term_upto_univ_napp Σ Re Rle napp t t'. Proof. intros. eapply eq_term_upto_univ_impl. 5:eauto. @@ -1154,7 +1154,7 @@ Qed. Lemma leq_term_leq_term_napp Σ Re Rle napp t t' : RelationClasses.subrelation Re Rle -> - eq_term_upto_univ Σ Re Rle t t' -> + eq_term_upto_univ Σ Re Rle t t' -> eq_term_upto_univ_napp Σ Re Rle napp t t'. Proof. intros. eapply eq_term_upto_univ_impl. 5:eauto. @@ -1249,7 +1249,7 @@ Proof. subst. constructor ; auto. Qed. -Lemma valid_constraints_empty {cf} i : +Lemma valid_constraints_empty {cf} i : valid_constraints (empty_ext empty_global_env) (subst_instance_cstrs i (empty_ext empty_global_env)). Proof. red. destruct check_univs => //. @@ -1429,10 +1429,10 @@ Qed. Hint Resolve All2_fold_nil : pcuic. Lemma eq_context_upto_smash_context Σ ctx ctx' x y : - eq_context_upto Σ eq eq ctx ctx' -> eq_context_upto Σ eq eq x y -> + eq_context_upto Σ eq eq ctx ctx' -> eq_context_upto Σ eq eq x y -> eq_context_upto Σ eq eq (smash_context ctx x) (smash_context ctx' y). Proof. - induction x in ctx, ctx', y |- *; intros eqctx eqt; inv eqt; simpl; + induction x in ctx, ctx', y |- *; intros eqctx eqt; inv eqt; simpl; try split; auto; try constructor; auto. depelim X0 => /=. - apply IHx; auto. apply eq_context_upto_cat; auto. constructor; pcuic. @@ -1441,12 +1441,12 @@ Proof. Qed. Lemma eq_context_upto_nth_error Σ Re Rle ctx ctx' n : - eq_context_upto Σ Re Rle ctx ctx' -> + eq_context_upto Σ Re Rle ctx ctx' -> rel_option (eq_decl_upto_gen Σ Re Rle) (nth_error ctx n) (nth_error ctx' n). Proof. induction 1 in n |- *. - rewrite nth_error_nil. constructor. - - destruct n; simpl; auto. + - destruct n; simpl; auto. constructor. depelim p; constructor; intuition auto; now constructor. Qed. @@ -1461,7 +1461,7 @@ Proof. intros Σ Re Re' Rle Rle' hR hR' hReRle' Γ Δ h. induction h. - constructor. - - constructor; auto. + - constructor; auto. depelim p; constructor; auto. all:eapply eq_term_upto_univ_impl. 5,10,15:tea. all:eauto. all:now transitivity Re'. @@ -1623,7 +1623,7 @@ Lemma R_global_instance_flip Σ gr napp Proof. intros Rerefl Rlerefl Resym Retrans Rletrans incl incl'. rewrite /R_global_instance /R_opt_variance. - destruct global_variance as [vs|] eqn:var. + destruct global_variance as [vs|] eqn:var. - induction u in vs, v |- *; destruct v; simpl; auto; destruct vs as [|v' vs]; simpl; auto. intros [Ra Ru']. split. @@ -1652,7 +1652,7 @@ Proof. all:try solve [now symmetry]. all:eauto using R_global_instance_flip. - eapply All2_sym. solve_all. - * eapply eq_context_sym; try tc. tas. + * eapply eq_context_sym; try tc. tas. * now eapply eq_term_upto_univ_sym. - eapply All2_sym. solve_all. now eapply eq_term_upto_univ_sym. @@ -1678,14 +1678,14 @@ Qed. Notation eq_annots Γ Δ := (Forall2 (fun na decl => eq_binder_annot na (decl_name decl)) Γ Δ). -Lemma eq_context_gen_binder_annot Γ Δ : +Lemma eq_context_gen_binder_annot Γ Δ : eq_context_gen eq eq Γ Δ -> eq_annots (forget_types Γ) Δ. Proof. induction 1; constructor; auto. destruct p; auto. Qed. -Lemma eq_annots_fold (Γ : list aname) (f : nat -> term -> term) (Δ : context) : +Lemma eq_annots_fold (Γ : list aname) (f : nat -> term -> term) (Δ : context) : eq_annots Γ (fold_context_k f Δ) <-> eq_annots Γ Δ. Proof. induction Δ in Γ |- *. @@ -1695,13 +1695,13 @@ Proof. now apply IHΔ. Qed. -Lemma eq_annots_subst_context (Γ : list aname) s k (Δ : context) : +Lemma eq_annots_subst_context (Γ : list aname) s k (Δ : context) : eq_annots Γ (subst_context s k Δ) <-> eq_annots Γ Δ. Proof. apply eq_annots_fold. Qed. -Lemma eq_annots_lift_context (Γ : list aname) n k (Δ : context) : +Lemma eq_annots_lift_context (Γ : list aname) n k (Δ : context) : eq_annots Γ (lift_context n k Δ) <-> eq_annots Γ Δ. Proof. apply eq_annots_fold. @@ -1715,7 +1715,7 @@ Proof. split; intro; eapply Forall2_impl; tea; apply Hfg. Qed. -Lemma eq_annots_subst_instance_ctx (Γ : list aname) u (Δ : context) : +Lemma eq_annots_subst_instance_ctx (Γ : list aname) u (Δ : context) : eq_annots Γ Δ@[u] <-> eq_annots Γ Δ. Proof. etransitivity. eapply Forall2_map_right. @@ -1729,6 +1729,6 @@ Lemma eq_annots_inst_case_context (Γ : list aname) pars puinst (ctx : context) Proof. etransitivity. symmetry; eapply (eq_annots_subst_instance_ctx _ puinst). etransitivity. - symmetry; eapply (eq_annots_subst_context _ (List.rev pars) 0). + symmetry; eapply (eq_annots_subst_context _ (List.rev pars) 0). reflexivity. Qed. diff --git a/pcuic/theories/PCUICEtaExpand.v b/pcuic/theories/PCUICEtaExpand.v index b098cafa9..8e9f7e19a 100644 --- a/pcuic/theories/PCUICEtaExpand.v +++ b/pcuic/theories/PCUICEtaExpand.v @@ -29,14 +29,14 @@ Inductive expanded (Γ : list nat) : term -> Prop := | expanded_tConst (c : kername) (u : Instance.t) : expanded Γ (tConst c u) | expanded_tInd (ind : inductive) (u : Instance.t) : expanded Γ (tInd ind u) | expanded_tCase (ci : case_info) (type_info:predicate term) - (discr:term) (branches : list (branch term)) : expanded Γ discr -> + (discr:term) (branches : list (branch term)) : expanded Γ discr -> Forall (expanded Γ) type_info.(pparams) -> Forall (fun br => ∥ All_fold (fun Δ d => ForOption (fun b => expanded (repeat 0 #|Δ| ++ repeat 0 #|type_info.(pparams)|) b) d.(decl_body)) br.(bcontext) ∥ /\ - expanded (repeat 0 #|br.(bcontext)| ++ Γ) br.(bbody)) branches -> + expanded (repeat 0 #|br.(bcontext)| ++ Γ) br.(bbody)) branches -> expanded Γ (tCase ci type_info discr branches) | expanded_tProj (proj : projection) (t : term) : expanded Γ t -> expanded Γ (tProj proj t) -| expanded_tFix (mfix : mfixpoint term) (idx : nat) args d : +| expanded_tFix (mfix : mfixpoint term) (idx : nat) args d : Forall (fun d => isLambda d.(dbody) /\ let ctx := rev_map (fun d => 1 + d.(rarg)) mfix in expanded (ctx ++ Γ) d.(dbody)) mfix -> Forall (expanded Γ) args -> args <> [] -> @@ -97,7 +97,7 @@ Lemma expanded_ind : P Γ (tCase ci type_info discr branches)) -> (forall (Γ : list nat) (proj : projection) (t : term), expanded Σ Γ t -> P Γ t -> P Γ (tProj proj t)) -> - (forall (Γ : list nat) (mfix : mfixpoint term) (idx : nat) + (forall (Γ : list nat) (mfix : mfixpoint term) (idx : nat) (args : list term) (d : def term), Forall (fun d0 : def term => @@ -115,9 +115,9 @@ Lemma expanded_ind : Forall (fun d : def term => expanded Σ (repeat 0 #|mfix| ++ Γ) (dbody d)) mfix -> Forall (fun d : def term => P (repeat 0 #|mfix| ++ Γ) (dbody d)) mfix -> P Γ (tCoFix mfix idx)) -> - (forall (Γ : list nat) (ind : inductive) (c : nat) + (forall (Γ : list nat) (ind : inductive) (c : nat) (u : Instance.t) (mind : mutual_inductive_body) - (idecl : one_inductive_body) (cdecl : constructor_body) + (idecl : one_inductive_body) (cdecl : constructor_body) (args : list term), declared_constructor Σ (ind, c) mind idecl cdecl -> #|args| >= ind_npars mind + context_assumptions (cstr_args cdecl) -> @@ -160,7 +160,7 @@ Record expanded_constructor_decl Σ mdecl cdecl := { expanded_cstr_args : expanded_context Σ (repeat 0 (#|mdecl.(ind_params)| + #|mdecl.(ind_bodies)|)) cdecl.(cstr_args) }. (* expanded_cstr_indices : All (expanded Σ []) cdecl.(cstr_indices); *) (* expanded_cstr_type : expanded Σ (repeat 0 #|mdecl.(ind_bodies)|) cdecl.(cstr_type) }. *) - + Record expanded_inductive_decl Σ mdecl idecl := { (* expanded_ind_type : expanded Σ [] idecl.(ind_type); *) expanded_ind_ctors : Forall (expanded_constructor_decl Σ mdecl) idecl.(ind_ctors) }. @@ -174,10 +174,10 @@ Definition expanded_decl Σ d := | ConstantDecl cb => expanded_constant_decl Σ cb | InductiveDecl idecl => expanded_minductive_decl Σ idecl end. - + Inductive expanded_global_declarations (univs : ContextSet.t) retro : forall (Σ : global_declarations), Prop := | expanded_global_nil : expanded_global_declarations univs retro [] -| expanded_global_cons decl Σ : expanded_global_declarations univs retro Σ -> +| expanded_global_cons decl Σ : expanded_global_declarations univs retro Σ -> expanded_decl {| universes := univs; declarations := Σ; retroknowledge := retro |} decl.2 -> expanded_global_declarations univs retro (decl :: Σ). @@ -191,7 +191,7 @@ Definition expanded_pcuic_program (p : pcuic_program) := Lemma All_tip {A} {P : A -> Type} {a : A} : P a <~> All P [a]. Proof. split; intros. repeat constructor; auto. now depelim X. Qed. -Lemma expanded_mkApps_expanded {Σ Γ f args} : +Lemma expanded_mkApps_expanded {Σ Γ f args} : expanded Σ Γ f -> All (expanded Σ Γ) args -> expanded Σ Γ (mkApps f args). Proof. @@ -211,10 +211,10 @@ Proof. - eapply expanded_mkApps. now rewrite eqc. auto. solve_all. Qed. -Lemma expanded_lift Σ n k b Γ Δ Δ' : +Lemma expanded_lift Σ n k b Γ Δ Δ' : #|Γ| = k -> #|Δ'| = n -> - expanded Σ (Γ ++ Δ) b -> + expanded Σ (Γ ++ Δ) b -> expanded Σ (Γ ++ Δ' ++ Δ) (lift n k b). Proof. intros Hk Hn. @@ -251,7 +251,7 @@ Proof. - rewrite lift_mkApps. cbn. eapply expanded_tFix. + solve_all. - specialize (a + specialize (a (rev_map (fun d0 : def term => S (rarg d0)) (map (map_def (lift n' k) (lift n' (#|mfix| + k))) mfix) ++ Γ') n' (#|mfix| + k) Hn). forward a. { rewrite rev_map_spec; len. } @@ -273,10 +273,10 @@ Proof. solve_all. Qed. -Lemma expanded_subst Σ a k b Γ Δ : +Lemma expanded_subst Σ a k b Γ Δ : #|Γ| = k -> - Forall (expanded Σ Δ) a -> - expanded Σ (Γ ++ repeat 0 #|a| ++ Δ) b -> + Forall (expanded Σ Δ) a -> + expanded Σ (Γ ++ repeat 0 #|a| ++ Δ) b -> expanded Σ (Γ ++ Δ) (subst a k b). Proof. intros Hk H. @@ -289,16 +289,16 @@ Proof. destruct (Nat.leb_spec k n). destruct (nth_error a _) eqn:hnth. * eapply expanded_mkApps_expanded. - eapply nth_error_forall in H; tea. + eapply nth_error_forall in H; tea. eapply (expanded_lift Σ k 0 _ [] Δ Γ'); auto. - solve_all. + solve_all. * rewrite nth_error_app_ge in H0. lia. eapply nth_error_None in hnth. rewrite nth_error_app_ge in H0. rewrite repeat_length. lia. rewrite repeat_length in H0. eapply expanded_tRel. rewrite nth_error_app_ge. lia. erewrite <- H0. lia_f_equal. len. solve_all. - * rewrite nth_error_app_lt in H0. lia. + * rewrite nth_error_app_lt in H0. lia. eapply expanded_tRel. rewrite nth_error_app_lt. lia. tea. now len. solve_all. - cbn. econstructor. @@ -318,7 +318,7 @@ Proof. - rewrite subst_mkApps. cbn. eapply expanded_tFix. + solve_all. now eapply isLambda_subst. - specialize (a0 + specialize (a0 (rev_map (fun d0 : def term => S (rarg d0)) (map (map_def (subst a k) (subst a (#|mfix| + k))) mfix) ++ Γ') (#|mfix| + k)). forward a0 by len. @@ -328,7 +328,7 @@ Proof. + solve_all. + now destruct args. + rewrite nth_error_map /= H5 //. - + len. + + len. - cbn. constructor. solve_all. specialize (a0 (repeat 0 #|mfix| ++ Γ') (#|mfix| + k)). @@ -376,7 +376,7 @@ Proof. * rewrite expand_lets_vass /= //. rewrite !repeat_app -!app_assoc. intros exp. relativize (context_assumptions Γ). - eapply H. lia. + eapply H. lia. { eapply All_fold_app_inv in ha as []. depelim a. cbn in f. depelim a. eapply All_fold_impl; tea. cbn; intros. @@ -406,7 +406,7 @@ Proof. - econstructor; eauto. 2:solve_all. rewrite subst_instance_isConstruct subst_instance_isFix subst_instance_isRel //. - econstructor; eauto. cbn. solve_all. - solve_all. + solve_all. - cbn; eapply expanded_tFix. solve_all. rewrite subst_instance_isLambda //. rewrite rev_map_spec map_map_compose -rev_map_spec //. solve_all. now destruct args => //. diff --git a/pcuic/theories/PCUICExpandLets.v b/pcuic/theories/PCUICExpandLets.v index 132f46a3d..f3bda4e0a 100644 --- a/pcuic/theories/PCUICExpandLets.v +++ b/pcuic/theories/PCUICExpandLets.v @@ -2,7 +2,7 @@ (* From Coq Require Import Uint63 FloatOps FloatAxioms. *) From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICTyping PCUICProgram. -(** This translation expands lets in constructor arguments, so that +(** This translation expands lets in constructor arguments, so that iota reduction reduces to a simple substitution operation with no let expansion involved. *) @@ -10,10 +10,10 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICTyping Definition trans_branch p (br : branch term) := if is_assumption_context br.(bcontext) then br else - {| bcontext := smash_context [] br.(bcontext); - bbody := - expand_lets - (subst_context (List.rev p.(pparams)) 0 br.(bcontext)@[p.(puinst)]) + {| bcontext := smash_context [] br.(bcontext); + bbody := + expand_lets + (subst_context (List.rev p.(pparams)) 0 br.(bcontext)@[p.(puinst)]) br.(bbody) |}. Fixpoint trans (t : term) : term := @@ -58,17 +58,17 @@ Definition trans_constructor_body i (mdecl : mutual_inductive_body) (d : PCUICEn let args' := trans_local d.(cstr_args) in let args := smash_context [] args' in let indices := map (expand_lets args') (map trans d.(cstr_indices)) in - {| cstr_name := d.(PCUICEnvironment.cstr_name); + {| cstr_name := d.(PCUICEnvironment.cstr_name); cstr_args := args; cstr_indices := indices; - cstr_type := + cstr_type := it_mkProd_or_LetIn (trans_local mdecl.(ind_params)) (it_mkProd_or_LetIn args (trans_cstr_concl mdecl i args indices)); cstr_arity := d.(PCUICEnvironment.cstr_arity) |}. Definition trans_projection_body (d : PCUICEnvironment.projection_body) := - {| proj_name := d.(PCUICEnvironment.proj_name); + {| proj_name := d.(PCUICEnvironment.proj_name); proj_type := trans d.(PCUICEnvironment.proj_type); proj_relevance := d.(PCUICEnvironment.proj_relevance) |}. @@ -92,7 +92,7 @@ Definition trans_minductive_body md := |}. Definition trans_constant_body bd := - {| cst_type := trans bd.(PCUICEnvironment.cst_type); + {| cst_type := trans bd.(PCUICEnvironment.cst_type); cst_body := option_map trans bd.(PCUICEnvironment.cst_body); cst_universes := bd.(PCUICEnvironment.cst_universes); cst_relevance := bd.(PCUICEnvironment.cst_relevance) |}. @@ -110,11 +110,10 @@ Definition trans_global_env (d : PCUICEnvironment.global_env) : global_env := {| universes := d.(PCUICEnvironment.universes); declarations := trans_global_decls d.(PCUICEnvironment.declarations); retroknowledge := d.(PCUICEnvironment.retroknowledge) |}. - + Definition trans_global (Σ : PCUICEnvironment.global_env_ext) : global_env_ext := (trans_global_env (fst Σ), snd Σ). Definition expand_lets_program (p : pcuic_program) : pcuic_program := - let Σ' := PCUICExpandLets.trans_global p.1 in + let Σ' := PCUICExpandLets.trans_global p.1 in ((build_global_env_map Σ', p.1.2), PCUICExpandLets.trans p.2). - \ No newline at end of file diff --git a/pcuic/theories/PCUICExpandLetsCorrectness.v b/pcuic/theories/PCUICExpandLetsCorrectness.v index 6ea800f3d..bd39ce758 100644 --- a/pcuic/theories/PCUICExpandLetsCorrectness.v +++ b/pcuic/theories/PCUICExpandLetsCorrectness.v @@ -10,7 +10,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICOnOne PCUICCases P PCUICLiftSubst PCUICEquality PCUICReduction PCUICCasesContexts PCUICTactics PCUICSigmaCalculus PCUICClosed PCUICClosedTyp PCUICContexts PCUICSubstitution PCUICWeakeningEnv PCUICWeakeningEnvTyp PCUICEquality - PCUICWeakeningConv PCUICWeakeningTyp PCUICCumulativity + PCUICWeakeningConv PCUICWeakeningTyp PCUICCumulativity PCUICUnivSubst PCUICUnivSubstitutionTyp PCUICGlobalEnv PCUICTyping PCUICGeneration PCUICConversion PCUICOnFreeVars PCUICValidity PCUICArities PCUICInversion @@ -29,9 +29,9 @@ Set Default Proof Using "Type*". branches of pattern-matchings, so that let-expansion becomes unnecessary on the resulting terms. The proof of correctness is complicated by the fact that the translation is valid only on well-scoped - terms, at the lowest level, so we carry around `on_free_vars` hypotheses everywhere. Reduction is - only preserved when we are translating well-typed terms, as it relies on even stronger invariants on the - representation of cases. Finally, the let-expansion of constructor's argument contexts is shown to + terms, at the lowest level, so we carry around `on_free_vars` hypotheses everywhere. Reduction is + only preserved when we are translating well-typed terms, as it relies on even stronger invariants on the + representation of cases. Finally, the let-expansion of constructor's argument contexts is shown to preserve positivity and the cumulativity relation for cumulative inductive types, which is not entirely trivial. *) @@ -62,7 +62,7 @@ Proof. now rewrite /trans_local map_app. Qed. -Lemma forget_types_map_context {term term'} (f : term' -> term) ctx : +Lemma forget_types_map_context {term term'} (f : term' -> term) ctx : forget_types (map_context f ctx) = forget_types ctx. Proof. now rewrite /forget_types map_map_context. @@ -89,7 +89,7 @@ Proof. apply/andP. split; auto. Qed. -Lemma All_fold_closed_on_free_vars_ctx n ctx : +Lemma All_fold_closed_on_free_vars_ctx n ctx : All_fold (λ Γ : context, ondecl (λ t : term, on_free_vars (closedP (#|Γ| + n) xpredT) (trans t))) ctx -> @@ -101,18 +101,18 @@ Proof. now intros; eapply on_decl_trans_on_free_vars_decl. Qed. -Definition plengths := +Definition plengths := (@context_assumptions_subst_context, @context_assumptions_app, @context_assumptions_subst_instance, @context_assumptions_lift_context, @expand_lets_ctx_length, @subst_context_length, @subst_instance_length, @expand_lets_k_ctx_length, @inds_length, @lift_context_length, @app_length, @List.rev_length, @extended_subst_length, @reln_length, - Nat.add_0_r, @app_nil_r, + Nat.add_0_r, @app_nil_r, @map_length, @mapi_length, @mapi_rec_length, @fold_context_k_length, @cofix_subst_length, @fix_subst_length, @smash_context_length, @arities_context_length, @context_assumptions_map). - + (* duplicated *) Lemma is_assumption_context_spec Γ : reflect (PCUICLiftSubst.assumption_context Γ) (is_assumption_context Γ). @@ -141,21 +141,21 @@ Proof. cbn. rewrite smash_context_length //. Qed. -Lemma trans_on_free_vars P t : +Lemma trans_on_free_vars P t : on_free_vars P t -> on_free_vars P (trans t). Proof. - revert P t. eapply term_on_free_vars_ind; cbn; auto; + revert P t. eapply term_on_free_vars_ind; cbn; auto; lazymatch goal with |- context [case_info] => idtac | _ => solve_all end. - intros; rtoProp; intuition auto. * solve_all. * now rewrite map_context_length. * rewrite map_length. rewrite test_context_k_closed_on_free_vars_ctx. - now eapply All_fold_closed_on_free_vars_ctx. + now eapply All_fold_closed_on_free_vars_ctx. * eapply All_forallb, All_map, All_map, All_impl; tea; cbv beta. intros br [hctx ihctx hb ihb]. len. rewrite test_context_k_closed_on_free_vars_ctx. - rewrite /trans_branch. + rewrite /trans_branch. elim: is_assumption_context_spec => isass. { cbn [map_branch bcontext]. apply/andP; split. now eapply All_fold_closed_on_free_vars_ctx. @@ -179,11 +179,11 @@ Proof. - unfold test_def. solve_all. cbn. now len in b1. Qed. -Lemma on_free_vars_ctx_trans k ctx : +Lemma on_free_vars_ctx_trans k ctx : on_free_vars_ctx (closedP k xpredT) ctx -> on_free_vars_ctx (closedP k xpredT) (map_context trans ctx). Proof. - intros H; apply on_free_vars_ctx_All_fold in H. + intros H; apply on_free_vars_ctx_All_fold in H. eapply All_fold_closed_on_free_vars_ctx. eapply All_fold_impl; tea; cbn. intros ? ? h. @@ -193,7 +193,7 @@ Proof. intros; try now eapply trans_on_free_vars. Qed. -Lemma trans_on_free_vars_ctx k ctx : +Lemma trans_on_free_vars_ctx k ctx : on_free_vars_ctx (shiftnP k xpred0) ctx -> on_free_vars_ctx (shiftnP k xpred0) (map_context trans ctx). Proof. @@ -215,11 +215,11 @@ Lemma trans_lift (t : S.term) P n k : trans (S.lift n k t) = T.lift n k (trans t). Proof. intros onfvs. - revert P t onfvs k. + revert P t onfvs k. apply: term_on_free_vars_ind; simpl; intros; try congruence. - f_equal. rewrite !map_map_compose. solve_all. - - f_equal; auto. - rewrite /T.map_predicate_k /id /PCUICAst.map_predicate /= /=. + - f_equal; auto. + rewrite /T.map_predicate_k /id /PCUICAst.map_predicate /= /=. f_equal. autorewrite with map; solve_all. rewrite map_context_length. solve_all. rewrite !map_map_compose. @@ -265,11 +265,11 @@ Proof. reflexivity. Qed. Lemma trans_global_ext_constraints Σ : S.global_ext_constraints Σ = T.global_ext_constraints (trans_global Σ). Proof. reflexivity. Qed. - + Lemma trans_mem_level_set l Σ: LevelSet.mem l (S.global_ext_levels Σ) -> LevelSet.mem l (T.global_ext_levels (trans_global Σ)). -Proof. auto. Qed. +Proof. auto. Qed. Lemma trans_in_level_set l Σ : LevelSet.In l (S.global_ext_levels Σ) -> @@ -310,7 +310,7 @@ Qed. Lemma trans_consistent_instance_ext {cf} Σ decl u: S.consistent_instance_ext Σ decl u -> T.consistent_instance_ext (trans_global Σ) decl u. -Proof. auto. Qed. +Proof. auto. Qed. Lemma trans_declared_inductive Σ ind mdecl idecl: S.declared_inductive Σ ind mdecl idecl -> @@ -341,7 +341,7 @@ Lemma trans_mkApps t args: mkApps (trans t) (map trans args). Proof. induction args in t |- *. - - reflexivity. + - reflexivity. - cbn [map]. cbn. rewrite IHargs. @@ -351,13 +351,13 @@ Qed. Lemma trans_decl_type decl: trans (decl_type decl) = decl_type (trans_decl decl). -Proof. +Proof. destruct decl. reflexivity. Qed. -Lemma expand_lets_subst_comm Γ k s : - expand_lets (subst_context s k Γ) ∘ subst s (#|Γ| + k) =1 +Lemma expand_lets_subst_comm Γ k s : + expand_lets (subst_context s k Γ) ∘ subst s (#|Γ| + k) =1 subst s (context_assumptions Γ + k) ∘ expand_lets Γ. Proof. unfold expand_lets, expand_lets_k; simpl; intros x. len. @@ -370,8 +370,8 @@ Lemma subst_context_subst_context s k s' Γ : subst_context s k (subst_context s' 0 Γ) = subst_context (map (subst s k) s') 0 (subst_context s (k + #|s'|) Γ). Proof. - induction Γ as [|[na [b|] ty] Γ']; simpl; auto; - rewrite !subst_context_snoc /= /subst_decl /map_decl /=; f_equal; + induction Γ as [|[na [b|] ty] Γ']; simpl; auto; + rewrite !subst_context_snoc /= /subst_decl /map_decl /=; f_equal; auto; f_equal; len; rewrite distr_subst_rec; lia_f_equal. Qed. @@ -408,17 +408,17 @@ Proof. * rewrite /trans_branch; rewrite !map_map_compose. eapply All_map_eq, All_impl; tea; cbv beta; intros. destruct X3 as [hctx ihctx hb ihb]. - rewrite /T.map_branch_k /=. + rewrite /T.map_branch_k /=. elim: is_assumption_context_spec => isass. { rewrite /map_branch /= ihb //. f_equal. now len. } f_equal; auto. len => /=. - rewrite ihb // /id. + rewrite ihb // /id. replace (context_assumptions (map_context trans (bcontext x))) with (context_assumptions ((subst_context (List.rev (map trans (pparams pred))) 0 (map_context trans (bcontext x))@[puinst pred]))). 2:now len. - cbn. + cbn. relativize (context_assumptions (bcontext x)). erewrite <- expand_lets_subst_comm. f_equal. 2:now len. 2:now len. @@ -436,7 +436,7 @@ Proof. cbn. rtoProp; intuition auto. unfold map_def; cbn. f_equal. rewrite a //. solve_all. rewrite b1 //. solve_all. cbn. now len. - - f_equal. rewrite !map_map_compose. + - f_equal. rewrite !map_map_compose. repeat toAll. eapply All_map_eq, All_impl; tea. cbn. rtoProp; intuition auto. unfold map_def; cbn. f_equal. rewrite a //. solve_all. @@ -449,12 +449,12 @@ Lemma trans_subst_ctx (Γ : context) xs k t : trans (S.subst xs k t) = T.subst (map trans xs) k (trans t). Proof. - intros ont onxs. + intros ont onxs. now erewrite trans_subst; tea. Qed. Lemma trans_subst10 u p q B : - on_free_vars p B -> + on_free_vars p B -> on_free_vars q u -> trans (S.subst1 u 0 B) = T.subst10 (trans u) (trans B). @@ -468,7 +468,7 @@ Lemma trans_subst_instance u t: subst_instance u (trans t). Proof. induction t in u |- * using PCUICInduction.term_forall_list_ind;cbn;auto;try congruence. - - do 2 rewrite map_map. + - do 2 rewrite map_map. f_equal. apply All_map_eq. solve_all. - red in X, X0. @@ -498,7 +498,7 @@ Qed. Lemma trans_subst_instance_ctx Γ u : trans_local Γ@[u] = (trans_local Γ)@[u]. Proof. - rewrite /subst_instance /= /trans_local /SE.subst_instance_context /subst_instance_context + rewrite /subst_instance /= /trans_local /SE.subst_instance_context /subst_instance_context /map_context. rewrite !map_map_compose. apply map_ext. move => [na [b|] ty]; cbn; @@ -536,8 +536,8 @@ Proof. reflexivity. Qed. -Lemma trans_inds ind u mdecl : - map trans (PCUICAst.inds (inductive_mind ind) u (SE.ind_bodies mdecl)) = +Lemma trans_inds ind u mdecl : + map trans (PCUICAst.inds (inductive_mind ind) u (SE.ind_bodies mdecl)) = inds (inductive_mind ind) u (ind_bodies (trans_minductive_body mdecl)). Proof. rewrite PCUICCases.inds_spec inds_spec. @@ -548,7 +548,7 @@ Qed. Lemma trans_declared_projection Σ p mdecl idecl cdecl pdecl : let ind := (inductive_ind p.(proj_ind)) in S.declared_projection Σ.1 p mdecl idecl cdecl pdecl -> - T.declared_projection (trans_global Σ).1 p (trans_minductive_body mdecl) (trans_one_ind_body mdecl ind idecl) + T.declared_projection (trans_global Σ).1 p (trans_minductive_body mdecl) (trans_one_ind_body mdecl ind idecl) (trans_constructor_body ind mdecl cdecl) (trans_projection_body pdecl). Proof. intros ind []. split; [|split]. @@ -637,7 +637,7 @@ Proof. generalize mfix at 1 2 3 5. induction mfix; trivial. simpl; intros mfix' hfvs. f_equal. - now eapply IHmfix. + now eapply IHmfix. Qed. Lemma trans_unfold_cofix p mfix idx narg fn : @@ -659,9 +659,9 @@ Proof. generalize mfix at 1 2 3 5. induction mfix; trivial. simpl; intros mfix' hfvs. f_equal. - now eapply IHmfix. + now eapply IHmfix. Qed. - + Lemma trans_is_constructor: forall (args : list S.term) (narg : nat), is_constructor narg args = true -> is_constructor narg (map trans args) = true. @@ -674,7 +674,7 @@ Proof. destruct t0 => //. apply decompose_app_rec_inv in da. simpl in da. subst t. rewrite trans_mkApps /=. - rewrite decompose_app_rec_mkApps //. + rewrite decompose_app_rec_mkApps //. Qed. Lemma refine_red1_r Σ Γ t u u' : u = u' -> red1 Σ Γ t u -> red1 Σ Γ t u'. @@ -712,7 +712,7 @@ Proof. now move/andP: hx. Qed. -Lemma trans_subst_decl p q s k d : +Lemma trans_subst_decl p q s k d : on_free_vars_terms p s -> on_free_vars_decl q d -> trans_decl (SE.subst_decl s k d) = subst_decl (map trans s) k (trans_decl d). @@ -720,16 +720,16 @@ Proof. destruct d as [na [b|] ty]; cbn; rewrite /trans_decl /= /subst_decl /= /map_decl /=. intros ons ond. f_equal. f_equal. - rewrite (trans_subst q p) //. + rewrite (trans_subst q p) //. now move/andP: ond => /=. - rewrite (trans_subst q p) //. + rewrite (trans_subst q p) //. now move/andP: ond => /=. intros ons ond. f_equal. f_equal. - rewrite (trans_subst q p) //. + rewrite (trans_subst q p) //. Qed. - -Lemma trans_subst_context p q s k Γ : + +Lemma trans_subst_context p q s k Γ : on_free_vars_ctx p Γ -> on_free_vars_terms q s -> trans_local (SE.subst_context s k Γ) = subst_context (map trans s) k (trans_local Γ). @@ -741,23 +741,23 @@ Proof. now apply IHΓ. Qed. -Lemma trans_lift_decl p n k d : +Lemma trans_lift_decl p n k d : on_free_vars_decl p d -> trans_decl (SE.lift_decl n k d) = lift_decl n k (trans_decl d). Proof. destruct d as [na [b|] ty]; cbn; rewrite /trans_decl /= /lift_decl /= /map_decl /=. intros ond. f_equal. f_equal. - rewrite (trans_lift _ p) //. + rewrite (trans_lift _ p) //. now move/andP: ond => /=. - rewrite (trans_lift _ p) //. + rewrite (trans_lift _ p) //. now move/andP: ond => /=. intros ond. f_equal. f_equal. - rewrite (trans_lift _ p) //. + rewrite (trans_lift _ p) //. Qed. -Lemma trans_lift_context p n k Γ : +Lemma trans_lift_context p n k Γ : on_free_vars_ctx p Γ -> trans_local (SE.lift_context n k Γ) = lift_context n k (trans_local Γ). Proof. @@ -768,7 +768,7 @@ Proof. now apply IHΓ. Qed. -Lemma trans_smash_context p Γ Δ : +Lemma trans_smash_context p Γ Δ : on_free_vars_ctx (shiftnP #|Δ| p) Γ -> on_free_vars_ctx p Δ -> trans_local (SE.smash_context Γ Δ) = smash_context (trans_local Γ) (trans_local Δ). @@ -784,7 +784,7 @@ Proof. f_equal. rewrite (trans_subst_context (shiftnP (S #|Δ|) p) (shiftnP #|Δ| p)) //. move/andP: ona => [] /= -> //; cbn; auto. - rewrite (IHΔ p) //. + rewrite (IHΔ p) //. rewrite on_free_vars_ctx_app /=. cbn. rewrite shiftnP0. move/andP: ona => [] _ ->. now rewrite shiftnP_add. f_equal. rewrite trans_local_app //. @@ -795,7 +795,7 @@ Proof. induction ctx as [|[na [b|] ty] ctx]; simpl; auto; lia. Qed. -Lemma on_free_vars_ctx_k_eq p n Γ : +Lemma on_free_vars_ctx_k_eq p n Γ : on_free_vars_ctx_k p n Γ = on_free_vars_ctx (shiftnP n p) Γ. Proof. rewrite /on_free_vars_ctx_k. @@ -824,7 +824,7 @@ Proof. f_equal; eauto. Qed. -Lemma trans_expand_lets_k p Γ k T : +Lemma trans_expand_lets_k p Γ k T : on_free_vars_ctx p Γ -> on_free_vars (shiftnP #|Γ| p) T -> trans (SE.expand_lets_k Γ k T) = expand_lets_k (trans_local Γ) k (trans T). @@ -839,7 +839,7 @@ Proof. now len. Qed. -Lemma trans_expand_lets p Γ T : +Lemma trans_expand_lets p Γ T : on_free_vars_ctx p Γ -> on_free_vars (shiftnP #|Γ| p) T -> trans (expand_lets Γ T) = expand_lets (trans_local Γ) (trans T). @@ -849,7 +849,7 @@ Proof. rewrite (trans_expand_lets_k p) //. Qed. -Lemma trans_expand_lets_map p Γ T : +Lemma trans_expand_lets_map p Γ T : on_free_vars_ctx p Γ -> on_free_vars_terms (shiftnP #|Γ| p) T -> map trans (map (expand_lets Γ) T) = map (expand_lets (trans_local Γ)) (map trans T). @@ -859,7 +859,7 @@ Proof. rewrite (trans_expand_lets p) //. Qed. -Lemma alpha_eq_trans {Γ Δ} : +Lemma alpha_eq_trans {Γ Δ} : eq_context_upto_names Γ Δ -> eq_context_upto_names (trans_local Γ) (trans_local Δ). Proof. @@ -892,16 +892,16 @@ Qed. Section wtsub. Context {cf} {Σ : PCUICEnvironment.global_env_ext} {wfΣ : PCUICTyping.wf Σ}. Import PCUICAst. - Definition wt_subterm Γ (t : term) : Type := + Definition wt_subterm Γ (t : term) : Type := let wt := wt Σ in match t with | tLambda na A B => wt Γ A × wt (Γ ,, vass na A) B | tProd na A B => wt Γ A × wt (Γ ,, vass na A) B | tLetIn na b ty b' => [× wt Γ b, wt Γ ty & wt (Γ ,, vdef na b ty) b'] | tApp f a => wt Γ f × wt Γ a - | tCase ci p c brs => + | tCase ci p c brs => All (wt Γ) p.(pparams) × - ∑ mdecl idecl, + ∑ mdecl idecl, [× declared_inductive Σ ci mdecl idecl, consistent_instance_ext Σ (PCUICEnvironment.ind_universes mdecl) (PCUICAst.puinst p), wf_predicate mdecl idecl p, @@ -911,16 +911,16 @@ Section wtsub. (PCUICEnvironment.smash_context [] (PCUICEnvironment.ind_params mdecl)@[PCUICAst.puinst p]), wt (Γ ,,, PCUICCases.case_predicate_context ci mdecl idecl p) p.(preturn), wt Γ c & - All2i (fun i cdecl br => + All2i (fun i cdecl br => [× wf_branch cdecl br, All2 (PCUICEquality.compare_decls eq eq) (bcontext br) (PCUICCases.cstr_branch_context ci mdecl cdecl), wf_local_rel Σ (Γ ,,, smash_context [] (ind_params mdecl)@[p.(puinst)]) br.(bcontext)@[p.(puinst)], - All2 (PCUICEquality.compare_decls eq eq) + All2 (PCUICEquality.compare_decls eq eq) (Γ ,,, PCUICCases.case_branch_context ci mdecl p (forget_types br.(bcontext)) cdecl) (Γ ,,, inst_case_branch_context p br) & wt (Γ ,,, PCUICCases.case_branch_context ci mdecl p (forget_types br.(bcontext)) cdecl) br.(bbody)]) 0 idecl.(ind_ctors) brs] | tProj p c => wt Γ c - | tFix mfix idx | tCoFix mfix idx => + | tFix mfix idx | tCoFix mfix idx => All (fun d => wt Γ d.(dtype) × wt (Γ ,,, fix_context mfix) d.(dbody)) mfix | tEvar _ l => False | tRel i => wf_local Σ Γ @@ -1013,16 +1013,16 @@ Proof. econstructor 3; tea. constructor. reflexivity. Qed. -Definition TTconv {cf} (Σ : global_env_ext) Γ : relation term := +Definition TTconv {cf} (Σ : global_env_ext) Γ : relation term := clos_refl_sym_trans (relation_disjunction (red1 Σ Γ) (eq_term Σ (T.global_ext_constraints Σ))). Lemma red1_conv {cf} (Σ : global_env_ext) Γ T U : red1 Σ Γ T U -> TTconv Σ Γ T U. Proof. intros r. - now repeat constructor. + now repeat constructor. Qed. -Lemma trans_expand_lets_ctx p q Γ Δ : +Lemma trans_expand_lets_ctx p q Γ Δ : on_free_vars_ctx p Γ -> on_free_vars_ctx q Δ -> trans_local (SE.expand_lets_ctx Γ Δ) = expand_lets_ctx (trans_local Γ) (trans_local Δ). @@ -1034,13 +1034,13 @@ Proof. erewrite trans_lift_context; tea. rewrite context_assumptions_map map_length //. erewrite <- on_free_vars_ctx_lift_context; tea. - eapply on_free_vars_extended_subst. rewrite on_free_vars_ctx_k_eq shiftnP0; tea. + eapply on_free_vars_extended_subst. rewrite on_free_vars_ctx_k_eq shiftnP0; tea. Qed. Lemma trans_cstr_branch_context p i ci mdecl cdecl : on_free_vars_ctx p (ind_params mdecl) -> on_free_vars_ctx (shiftnP (#|ind_params mdecl| + #|ind_bodies mdecl|) xpred0) (cstr_args cdecl) -> - smash_context [] (trans_local (PCUICCases.cstr_branch_context ci mdecl cdecl)) = + smash_context [] (trans_local (PCUICCases.cstr_branch_context ci mdecl cdecl)) = cstr_branch_context ci (trans_minductive_body mdecl) (trans_constructor_body i mdecl cdecl). Proof. move=> onpars onargs. @@ -1060,11 +1060,11 @@ Qed. Lemma trans_cstr_branch_context_inst p i ci mdecl cdecl u : on_free_vars_ctx p (ind_params mdecl) -> on_free_vars_ctx (shiftnP (#|ind_params mdecl| + #|ind_bodies mdecl|) xpred0) (cstr_args cdecl) -> - smash_context [] (trans_local (PCUICCases.cstr_branch_context ci mdecl cdecl)@[u]) = + smash_context [] (trans_local (PCUICCases.cstr_branch_context ci mdecl cdecl)@[u]) = (cstr_branch_context ci (trans_minductive_body mdecl) (trans_constructor_body i mdecl cdecl))@[u]. Proof. move=> onps onargs. - rewrite trans_subst_instance_ctx -(PCUICUnivSubstitutionConv.subst_instance_smash _ _ []). + rewrite trans_subst_instance_ctx -(PCUICUnivSubstitutionConv.subst_instance_smash _ _ []). rewrite (trans_cstr_branch_context p i) //. Qed. @@ -1080,7 +1080,7 @@ Proof. Qed. Lemma trans_assumption_context Γ : assumption_context Γ <-> assumption_context (trans_local Γ). -Proof. +Proof. induction Γ; cbn; auto. reflexivity. split. - intros ass; depelim ass; constructor; auto. @@ -1115,7 +1115,7 @@ Proof. len. rewrite on_free_vars_ctx_subst_instance //. eapply on_free_vars_ctx_impl; tea. intros o. rewrite /shiftnP /=. rewrite orb_false_r. - repeat nat_compare_specs; auto => //. } + repeat nat_compare_specs; auto => //. } rewrite (trans_subst_context (shiftnP #|pred.(pparams)| xpred0) q). { rewrite on_free_vars_ctx_subst_instance //. } { rewrite [on_free_vars_terms _ _]forallb_rev //. } @@ -1182,7 +1182,7 @@ Qed. Require Import PCUICSpine. -Lemma trans_reln l p Γ : map trans (SE.reln l p Γ) = +Lemma trans_reln l p Γ : map trans (SE.reln l p Γ) = reln (map trans l) p (trans_local Γ). Proof. induction Γ as [|[na [b|] ty] Γ] in l, p |- *; simpl; auto. @@ -1197,7 +1197,7 @@ Qed. Lemma trans_ind_predicate_context ci mdecl idecl : is_closed_context (ind_params mdecl) -> on_free_vars_ctx (shiftnP #|ind_params mdecl| xpred0) (ind_indices idecl) -> - trans_local (PCUICCases.ind_predicate_context ci mdecl idecl) = + trans_local (PCUICCases.ind_predicate_context ci mdecl idecl) = (ind_predicate_context ci (trans_minductive_body mdecl) (trans_one_ind_body mdecl (inductive_ind ci) idecl)). Proof. @@ -1216,7 +1216,7 @@ Lemma trans_ind_predicate_context_eq p ci mdecl idecl : is_closed_context (ind_params mdecl) -> on_free_vars_ctx (shiftnP #|ind_params mdecl| xpred0) (ind_indices idecl) -> eq_context_upto_names (PCUICAst.pcontext p) - (PCUICCases.ind_predicate_context ci mdecl idecl) -> + (PCUICCases.ind_predicate_context ci mdecl idecl) -> All2 (λ (x : binder_annot name) (y : context_decl), eq_binder_annot x (decl_name y)) @@ -1235,7 +1235,7 @@ Lemma trans_cstr_branch_context_eq ci mdecl cdecl p i br : is_closed_context (ind_params mdecl) -> on_free_vars_ctx (shiftnP (#|ind_params mdecl| + #|ind_bodies mdecl|) xpred0) (cstr_args cdecl) -> - eq_context_upto_names (PCUICAst.bcontext br) + eq_context_upto_names (PCUICAst.bcontext br) (PCUICCases.cstr_branch_context ci mdecl cdecl) -> eq_context_upto_names (bcontext (trans_branch p (map_branch trans (map_context trans) br))) @@ -1301,7 +1301,7 @@ Proof. cbn. intros x y H. destruct y; apply H. Qed. -Lemma trans_local_set_binder nas Γ : +Lemma trans_local_set_binder nas Γ : trans_local (map2 PCUICEnvironment.set_binder_name nas Γ) = map2 set_binder_name nas (trans_local Γ). Proof. @@ -1375,7 +1375,7 @@ Qed. Lemma on_free_vars_ind_predicate_context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind mdecl idecl} : declared_inductive Σ ind mdecl idecl -> - on_free_vars_ctx (closedP (context_assumptions (ind_params mdecl)) xpredT) + on_free_vars_ctx (closedP (context_assumptions (ind_params mdecl)) xpredT) (ind_predicate_context ind mdecl idecl). Proof. intros decli. @@ -1385,15 +1385,15 @@ Proof. Qed. Lemma trans_case_predicate_context {cf} {Σ : PCUICEnvironment.global_env_ext} - {wfΣ : PCUICTyping.wf Σ} {Γ ci mdecl idecl p} : + {wfΣ : PCUICTyping.wf Σ} {Γ ci mdecl idecl p} : S.declared_inductive Σ ci mdecl idecl -> - S.consistent_instance_ext Σ (PCUICEnvironment.ind_universes mdecl) (PCUICAst.puinst p) → + S.consistent_instance_ext Σ (PCUICEnvironment.ind_universes mdecl) (PCUICAst.puinst p) → let parctx := (PCUICEnvironment.ind_params mdecl)@[PCUICAst.puinst p] in PCUICSpine.spine_subst Σ Γ (PCUICAst.pparams p) (List.rev (PCUICAst.pparams p)) (PCUICEnvironment.smash_context [] parctx) -> wf_predicate mdecl idecl p -> - let p' := map_predicate id trans trans trans_local p in + let p' := map_predicate id trans trans trans_local p in (case_predicate_context ci (trans_minductive_body mdecl) (trans_one_ind_body mdecl (inductive_ind ci) idecl) p') = (trans_local (PCUICCases.case_predicate_context ci mdecl idecl p)). Proof. @@ -1411,14 +1411,14 @@ Proof. eapply (on_free_vars_ind_predicate_context H). now eapply inst_subslet, subslet_open in X. rewrite map_rev. f_equal. - rewrite trans_subst_instance_ctx. + rewrite trans_subst_instance_ctx. rewrite trans_ind_predicate_context; pcuic. Qed. -Lemma OnOne2All2i_OnOne2All {A B : Type} (l1 l2 : list A) (l3 : list B) +Lemma OnOne2All2i_OnOne2All {A B : Type} (l1 l2 : list A) (l3 : list B) (R1 : A → A → Type) (R2 : nat → B → A → Type) (n : nat) (R3 : B -> A -> A -> Type) : - OnOne2 R1 l1 l2 → - All2i R2 n l3 l1 → + OnOne2 R1 l1 l2 → + All2i R2 n l3 l1 → (forall (n0 : nat) (x y : A) (z : B), R1 x y → R2 n0 z x → R3 z x y) → OnOne2All R3 l3 l1 l2. Proof. induction 1 in n, l3 |- *; intros H; depelim H. @@ -1439,7 +1439,7 @@ Proof. eapply map_ext. intros []; reflexivity. Qed. -Lemma trans_bcontext p br : +Lemma trans_bcontext p br : (bcontext (trans_branch p (map_branch trans (map_context trans) br))) = smash_context [] (trans_local (bcontext br)). Proof. rewrite /trans_branch. @@ -1448,8 +1448,8 @@ Proof. now cbn. Qed. -Lemma trans_bbody p br : - (bbody (trans_branch p (map_branch trans (map_context trans) br))) = +Lemma trans_bbody p br : + (bbody (trans_branch p (map_branch trans (map_context trans) br))) = expand_lets (subst_context (List.rev (pparams p)) 0 (trans_local (bcontext br))@[puinst p]) (trans (bbody br)). Proof. rewrite /trans_branch. @@ -1464,7 +1464,7 @@ Lemma OnOne2All_map2_map_all {A B I I'} {P} {i : list I} {l l' : list A} (g : B OnOne2All (fun i x y => P (g (f x) i) (f x) (f y)) i l l' -> OnOne2All P (map2 g (map f l) i) (map f l) (map f l'). Proof. induction 1; simpl; constructor; try congruence. len. - now rewrite map2_length !map_length. + now rewrite map2_length !map_length. Qed. Lemma wt_on_free_vars {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ t} : wt Σ Γ t -> on_free_vars (shiftnP #|Γ| xpred0) t. @@ -1474,12 +1474,12 @@ Qed. Ltac fuse_shifts := match goal with - [ H : is_true (on_free_vars (shiftnP 1 (shiftnP _ _)) _) |- _ ] => + [ H : is_true (on_free_vars (shiftnP 1 (shiftnP _ _)) _) |- _ ] => rewrite -> shiftnP_add in H; cbn in H end. -Ltac tofvs := repeat match goal with [ H : wt _ _ _ |- _ ] => apply wt_on_free_vars in H end; - try inv_on_free_vars; repeat fuse_shifts. +Ltac tofvs := repeat match goal with [ H : wt _ _ _ |- _ ] => apply wt_on_free_vars in H end; + try inv_on_free_vars; repeat fuse_shifts. #[local] Hint Extern 3 (is_true (_ && true)) => rewrite andb_true_r : pcuic. @@ -1490,7 +1490,7 @@ Qed. Lemma on_free_vars_ctx_cstr_branch_context {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {c mdecl idecl cdecl} : declared_constructor Σ c mdecl idecl cdecl -> - on_free_vars_ctx (shiftnP (context_assumptions (ind_params mdecl)) xpred0) + on_free_vars_ctx (shiftnP (context_assumptions (ind_params mdecl)) xpred0) (cstr_branch_context c.1 mdecl cdecl). Proof. intros. eapply closedn_ctx_on_free_vars. eapply (PCUICInstConv.closedn_ctx_cstr_branch_context H). @@ -1505,14 +1505,14 @@ Proof. now exists A. Qed. -Lemma wt_mkApps_inv {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ f args} : +Lemma wt_mkApps_inv {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ f args} : wt Σ Γ (mkApps f args) -> wt Σ Γ f × All (wt Σ Γ) args. Proof. intros [ha tapp]. eapply inversion_mkApps in tapp as [ty [tf targs]]. split. - exists ty; eauto. - - now eapply typing_spine_wt. + - now eapply typing_spine_wt. Qed. Lemma red_expand_lets {cf} (Σ : global_env_ext) {wfΣ : wf Σ} Γ Δ t t' : @@ -1538,7 +1538,7 @@ Proof. induction 1; cbn; auto. destruct p; cbn; auto. lia. Qed. -Lemma ws_cumul_pb_expand_lets {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {le} {Δ} {T T'} : +Lemma ws_cumul_pb_expand_lets {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {le} {Δ} {T T'} : Σ ;;; Γ ,,, Δ ⊢ T ≤[le] T' -> Σ ;;; Γ ,,, smash_context [] Δ ⊢ expand_lets Δ T ≤[le] expand_lets Δ T'. Proof. @@ -1556,7 +1556,7 @@ Proof. now eapply is_closed_context_smash_end. Qed. -Lemma red_terms_lift {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ ts us} : +Lemma red_terms_lift {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ ts us} : is_closed_context (Γ ,,, Δ) -> red_terms Σ Γ ts us -> red_terms Σ (Γ ,,, Δ) (map (lift0 #|Δ|) ts) (map (lift0 #|Δ|) us). @@ -1565,7 +1565,7 @@ Proof. eapply (weakening_closed_red (Γ' := [])) => //. Qed. -Lemma onfvs_app Γ Δ : is_closed_context (Γ ,,, Δ) -> +Lemma onfvs_app Γ Δ : is_closed_context (Γ ,,, Δ) -> is_closed_context Γ /\ on_free_vars_ctx (shiftnP #|Γ| xpred0) Δ. Proof. now rewrite on_free_vars_ctx_app => /andP. @@ -1577,8 +1577,8 @@ Lemma untyped_subslet_ws_cumul_ctx_pb {cf} {Γ Γ' Δ Δ'} {s} : Proof. induction 1; constructor; auto. Qed. - -Lemma weakening_is_closed_context Γ Δ : + +Lemma weakening_is_closed_context Γ Δ : is_closed_context (Γ ,,, Δ) -> is_closed_context (Γ ,,, smash_context [] Δ ,,, lift_context (context_assumptions Δ) 0 Δ). Proof. @@ -1666,7 +1666,7 @@ Proof. rewrite context_assumptions_smash_context /=. rewrite -[context_assumptions Γ0](smash_context_length []); cbn. relativize #|Γ0|. - eapply is_open_term_lift. + eapply is_open_term_lift. len. rewrite (All2_fold_length cum). now len in clb'. reflexivity. Qed. @@ -1702,7 +1702,7 @@ Proof. { eapply is_closed_context_subst; tea. eapply closed_red_terms_open_left in reds. solve_all. now rewrite -(untyped_subslet_length subs') (All2_length reds). } have cls' : is_closed_context (Γ,,, subst_context s' 0 Δ). - { eapply is_closed_context_subst; tea. eapply closed_red_terms_open_right in reds. solve_all. + { eapply is_closed_context_subst; tea. eapply closed_red_terms_open_right in reds. solve_all. now rewrite -(untyped_subslet_length subs'). } etransitivity. eapply red_expand_lets; tea. @@ -1732,7 +1732,7 @@ Proof. rewrite distr_lift_subst. constructor; auto. Qed. -Lemma OnOne2_All2i_All2 {A B} {P : A -> A -> Type} {Q R} {n} {l l' : list A} {l'' : list B} : +Lemma OnOne2_All2i_All2 {A B} {P : A -> A -> Type} {Q R} {n} {l l' : list A} {l'' : list B} : OnOne2 P l l' -> All2i Q n l'' l -> (forall n x y z, P x y -> Q n z x -> R x y) -> @@ -1751,7 +1751,7 @@ Qed. From MetaCoq.PCUIC Require Import PCUICUnivSubstitutionConv. -Lemma OnOne2_All_OnOne2 {A} {P : A -> A -> Type} {Q R} l l' : +Lemma OnOne2_All_OnOne2 {A} {P : A -> A -> Type} {Q R} l l' : OnOne2 P l l' -> All Q l -> (forall x y, Q x -> P x y -> R x y) -> @@ -1760,7 +1760,7 @@ Proof. induction 1; intros H; depelim H; intros IH; constructor; eauto. Qed. -Lemma OnOne2_All_All2 {A} {P : A -> A -> Type} {Q R} l l' : +Lemma OnOne2_All_All2 {A} {P : A -> A -> Type} {Q R} l l' : OnOne2 P l l' -> All Q l -> (forall x y, Q x -> P x y -> R x y) -> @@ -1771,14 +1771,14 @@ Proof. clear -H X; solve_all. Qed. -Lemma All2i_map_right_inv {A B C} {P : nat -> A -> B -> Type} {f : C -> B} n (l : list A) l' : +Lemma All2i_map_right_inv {A B C} {P : nat -> A -> B -> Type} {f : C -> B} n (l : list A) l' : All2i P n l (map f l') -> All2i (fun n x y => P n x (f y)) n l l'. Proof. induction l' in n, l |- *; cbn; intros h; depelim h; constructor; auto. Qed. -Lemma All2i_map_left_inv {A B C} {P : nat -> A -> B -> Type} {f : C -> A} n l l' : +Lemma All2i_map_left_inv {A B C} {P : nat -> A -> B -> Type} {f : C -> A} n l l' : All2i P n (map f l) l' -> All2i (fun n x y => P n (f x) y) n l l'. Proof. @@ -1792,7 +1792,7 @@ Proof. now rewrite closedP_shiftnP shiftnP0. Qed. -Lemma on_free_vars_ind_params {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {P ind mdecl idecl u} : +Lemma on_free_vars_ind_params {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {P ind mdecl idecl u} : declared_inductive Σ ind mdecl idecl -> on_free_vars_ctx P (ind_params mdecl)@[u]. Proof. @@ -1809,7 +1809,7 @@ Proof. repeat nat_compare_specs; cbn; auto. Qed. -Lemma is_closed_context_cstr_branch_context {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ ind mdecl idecl cdecl u} : +Lemma is_closed_context_cstr_branch_context {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ ind mdecl idecl cdecl u} : declared_constructor Σ ind mdecl idecl cdecl -> is_closed_context Γ -> is_closed_context (Γ ,,, (smash_context [] (ind_params mdecl))@[u] ,,, (cstr_branch_context ind.1 mdecl cdecl)@[u]). @@ -1820,36 +1820,36 @@ Proof. apply/andP; split. rewrite subst_instance_smash. eapply on_free_vars_ctx_smash => //. apply (on_free_vars_ind_params declc). - len. cbn. + len. cbn. rewrite on_free_vars_ctx_subst_instance. eapply on_free_vars_ctx_impl; [|eapply (on_free_vars_ctx_cstr_branch_context declc)]. intros i. rewrite shiftnP_add. eapply shiftnP_mon. move: (context_assumptions_bound (ind_params mdecl)). lia. Qed. -Lemma trans_untyped_subslet {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ s Δ} : +Lemma trans_untyped_subslet {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ s Δ} : wf_local Σ (Γ ,,, Δ) -> All (wt Σ Γ) s -> - untyped_subslet Γ s Δ -> + untyped_subslet Γ s Δ -> untyped_subslet (trans_local Γ) (map trans s) (trans_local Δ). Proof. induction 3 in |- *; cbn; try constructor; auto. cbn. depelim X. now depelim X0. depelim X. depelim X0. rewrite (trans_subst (shiftnP #|Γ ,,, Δ| xpred0) (shiftnP #|Γ| xpred0)). - red in l0. now eapply subject_is_open_term in l0. solve_all. now eapply wt_on_free_vars. + red in l0. now eapply subject_is_open_term in l0. solve_all. now eapply wt_on_free_vars. constructor ; auto. Qed. -Lemma untyped_subslet_length Γ s s' Δ : +Lemma untyped_subslet_length Γ s s' Δ : untyped_subslet Γ s Δ -> #|s| = #|s'| -> assumption_context Δ -> untyped_subslet Γ s' Δ. Proof. induction 1 in s' |- *; cbn; destruct s' => /= //. constructor. intros [=]. constructor ; auto. eapply IHX; auto. now depelim H. - intros. elimtype False; depelim H0. + intros. elimtype False; depelim H0. Qed. -Lemma wf_local_ind_params_weaken {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {ind mdecl u} : +Lemma wf_local_ind_params_weaken {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {ind mdecl u} : declared_minductive Σ ind mdecl -> wf_local Σ Γ -> consistent_instance_ext Σ (ind_universes mdecl) u -> @@ -1860,10 +1860,10 @@ Proof. now eapply on_minductive_wf_params. Qed. -Definition cf' cf := +Definition cf' cf := {| check_univs := cf.(@check_univs); - prop_sub_type := cf.(@prop_sub_type); - indices_matter := cf.(@indices_matter); + prop_sub_type := cf.(@prop_sub_type); + indices_matter := cf.(@indices_matter); lets_in_constructor_types := false |}. Notation wf_trans Σ := (@wf (cf' _) (trans_global_env Σ.1)). @@ -1875,17 +1875,17 @@ Lemma trans_red1 {cf} (Σ : global_env_ext) {wfΣ : wf Σ} {wfΣ' : wf_trans Σ} red (trans_global Σ) (trans_local Γ) (trans T) (trans U). Proof. induction 1 using red1_ind_all; simpl in *; intros wt; - match goal with + match goal with | |- context [tCase _ _ _ _] => idtac | |- context [tFix _ _] => idtac | |- context [tCoFix _ _] => idtac | _ => eapply wt_inv in wt; tea; cbn in wt; repeat outtimes end; try solve [econstructor; eauto]. - + - simpl. tofvs. rewrite (trans_subst_ctx Γ) /=; pcuic. eapply red1_red; constructor. - + - destruct wt. tofvs. rewrite (trans_subst_ctx Γ); pcuic. repeat constructor. - destruct nth_error eqn:Heq => //. simpl in H. noconf H. @@ -1894,7 +1894,7 @@ Proof. eapply nth_error_All_local_env in wt0; tea. cbn in wt0. now eapply subject_is_open_term. do 2 constructor. now rewrite nth_error_map Heq. - + - pose proof (wt_on_free_vars wt). inv_on_free_vars. destruct wt as [s Hs]. @@ -1912,7 +1912,7 @@ Proof. rewrite (proj2 declc) in Hcdecl'. noconf Hcdecl'. have lenbctx : context_assumptions (cstr_args cdecl) = context_assumptions (bcontext br). { rewrite (alpha_eq_context_assumptions _ _ bctxeq). - rewrite cstr_branch_context_assumptions. lia. } + rewrite cstr_branch_context_assumptions. lia. } relativize (trans (iota_red _ _ _ _)). eapply red1_red; eapply red_iota; tea; eauto. all:auto. * rewrite !nth_error_map H; reflexivity. @@ -1925,7 +1925,7 @@ Proof. rewrite -> on_free_vars_ctx_app in hbody. move/andP: hbody => [] //. } have onb : on_free_vars (shiftnP #|inst_case_branch_context p br| (shiftnP #|Γ| xpred0)) (bbody br). - { rewrite -(PCUICCasesContexts.inst_case_branch_context_eq bctxeq). + { rewrite -(PCUICCasesContexts.inst_case_branch_context_eq bctxeq). eapply subject_is_open_term in hbody. len in hbody. rewrite shiftnP_add //. } rewrite (trans_subst_ctx Γ). { len. rewrite lenskip. @@ -1933,7 +1933,7 @@ Proof. eapply on_free_vars_expand_lets_k => //. rewrite /inst_case_branch_context /inst_case_context. rewrite context_assumptions_subst_context context_assumptions_subst_instance. lia. } - { rewrite forallb_rev forallb_skipn //. + { rewrite forallb_rev forallb_skipn //. rewrite on_free_vars_mkApps in p3. move: p3 => /= //. } rewrite map_rev map_skipn. f_equal. rewrite (trans_expand_lets (shiftnP #|Γ| xpred0)) //. @@ -1951,27 +1951,27 @@ Proof. eapply alpha_eq_on_free_vars_ctx; [symmetry; tea|]. eapply on_free_vars_ctx_impl; [|eapply (on_free_vars_ctx_cstr_branch_context declc)]. intros i. rewrite /shiftnP. rewrite !orb_false_r. - move/Nat.ltb_lt => H'. apply Nat.ltb_lt. + move/Nat.ltb_lt => H'. apply Nat.ltb_lt. pose proof (context_assumptions_bound (ind_params mdecl)). lia. } { rewrite [on_free_vars_terms _ _]forallb_rev //. } rewrite map_rev. f_equal. rewrite trans_subst_instance_ctx //. now rewrite trans_bbody. - + - simpl. rewrite !trans_mkApps /=. eapply wt_mkApps_inv in wt as [wtf wtargs]. unfold is_constructor in H0. destruct nth_error eqn:hnth. pose proof (nth_error_Some_length hnth). destruct args. simpl. elimtype False; cbn in H1. lia. - cbn -[mkApps]. + cbn -[mkApps]. eapply red1_red, red_fix. apply (trans_unfold_fix (shiftnP #|Γ| xpred0)); eauto. now eapply wt_on_free_vars in wtf. eapply (trans_is_constructor (t0 :: args)). now rewrite /is_constructor hnth. discriminate. - + - rewrite trans_mkApps. rewrite !trans_mkApps; eauto with wf. eapply wt_inv in wt. cbn in wt. @@ -1983,18 +1983,18 @@ Proof. - rewrite !trans_mkApps. eapply wt_inv in wt. cbn in wt. - eapply wt_mkApps_inv in wt as []. + eapply wt_mkApps_inv in wt as []. apply (trans_unfold_cofix (shiftnP #|Γ| xpred0)) in H; eauto with wf. eapply red1_red, red_cofix_proj; eauto. now eapply wt_on_free_vars in w. - + - rewrite trans_subst_instance. eapply red1_red; econstructor. apply (trans_declared_constant _ c decl H). destruct decl. now simpl in *; subst cst_body0. - rewrite trans_mkApps; eauto with wf. simpl. eapply red1_red; constructor; now rewrite nth_error_map H. - + - eapply red_abs; eauto. - eapply red_abs; eauto. - destruct wt as []; eapply red_letin; eauto. @@ -2004,7 +2004,7 @@ Proof. eapply OnOne2_All_mix_left in X; tea. relativize (map_predicate id _ _ _ (set_pparams _ _)). eapply red_case. 5:reflexivity. all:try reflexivity. - cbn. + cbn. eapply OnOne2_All2. eapply OnOne2_map. 2:intros x y h; exact h. 2:reflexivity. eapply OnOne2_All_OnOne2; tea. cbv beta. @@ -2019,7 +2019,7 @@ Proof. { split => //. } split => //. cbn [bcontext bbody map_branch]. rewrite /id. rewrite (subst_instance_smash _ _ []) /=. - eapply (red_expand_lets_ctx (cf := cf' cf) (Σ := trans_global Σ) + eapply (red_expand_lets_ctx (cf := cf' cf) (Σ := trans_global Σ) (Γ' := (trans_local (smash_context [] (ind_params mdecl))@[puinst p])) (Γ'' := (trans_local (smash_context [] (ind_params mdecl))@[puinst p]))). * eapply alpha_eq_on_free_vars_ctx. @@ -2063,7 +2063,7 @@ Proof. eapply untyped_subslet_length. rewrite subst_instance_smash. exact s. len. eapply (OnOne2_length X). - pcuic. + pcuic. * eapply All2_rev. eapply All2_map. eapply OnOne2_All_All2; tea; cbv beta. intros x y wtx [[r Hr] wt]. @@ -2086,7 +2086,7 @@ Proof. specialize (IHX w1). rewrite -(inst_case_predicate_context_eq a) in IHX. eapply alpha_eq_trans in a. - rewrite trans_ind_predicate_context in a. + rewrite trans_ind_predicate_context in a. { eapply closed_ctx_is_closed_context, declared_inductive_closed_params; tea. } { epose proof (declared_inductive_closed_indices _ _ _ d). now eapply closedn_ctx_on_free_vars in H. } @@ -2097,7 +2097,7 @@ Proof. - eapply wt_inv in wt as [hpars [mdecl [idecl []]]]. eapply red_case_c; eauto. - + - pose proof (wt_on_free_vars wt). inv_on_free_vars. eapply forallb_All in p4. eapply wt_inv in wt as [hpars [mdecl [idecl []]]]. @@ -2133,7 +2133,7 @@ Proof. { move/andP: onfvs => [] onctx _. rewrite test_context_k_closed_on_free_vars_ctx in onctx. now rewrite on_free_vars_ctx_subst_instance. } { rewrite /on_free_vars_terms forallb_rev. solve_all. } - rewrite -!trans_local_app. + rewrite -!trans_local_app. intros r; eapply into_closed_red => //. { eapply trans_is_closed_context. rewrite -[SE.subst_context _ _ _](PCUICCasesContexts.inst_case_branch_context_eq (p:=p) a1). @@ -2163,7 +2163,7 @@ Proof. eapply OnOne2_All_mix_left in X; tea. eapply OnOne2_All2; tea; cbv beta. intros; intuition auto. cbn. noconf b0. rewrite H1; reflexivity. - cbn. + cbn. rewrite -(trans_fix_context (shiftnP #|Γ| xpred0) _ idx) //. now rewrite trans_local_app in X0. cbn; congruence. intros. repeat split; reflexivity. @@ -2184,9 +2184,9 @@ Proof. eapply OnOne2_All_mix_left in X; tea. eapply OnOne2_All2; tea; cbv beta. intros; intuition auto. cbn. noconf b0. rewrite H1; reflexivity. - cbn. + cbn. rewrite -(trans_fix_context (shiftnP #|Γ| xpred0) _ idx) //. - now rewrite trans_local_app in X0. cbn; congruence. + now rewrite trans_local_app in X0. cbn; congruence. intros. repeat split; reflexivity. Qed. @@ -2211,7 +2211,7 @@ Proof. destruct nth_error => /= //. rewrite nth_error_map. destruct nth_error => /= //. -Qed. +Qed. Lemma trans_eq_context_gen_eq_binder_annot Γ Δ : eq_context_gen eq eq Γ Δ -> @@ -2276,12 +2276,12 @@ Proof. rewrite /expand_lets /expand_lets_k. eapply eq_term_upto_univ_substs => //. rewrite (eq_context_upto_length eqctx). - rewrite (eq_context_upto_context_assumptions eqctx). + rewrite (eq_context_upto_context_assumptions eqctx). now eapply eq_term_upto_univ_lift. apply (PCUICConfluence.eq_context_extended_subst eqctx). Qed. -Lemma trans_eq_term_upto_univ {cf} {Σ : global_env} {Re Rle t u napp} : +Lemma trans_eq_term_upto_univ {cf} {Σ : global_env} {Re Rle t u napp} : Reflexive Re -> Reflexive Rle -> Transitive Re -> SubstUnivPreserving Re -> subrelation Re Rle -> @@ -2345,7 +2345,7 @@ Qed. From MetaCoq.PCUIC Require Import PCUICContextConversion. -Lemma wt_red1_wt {cf} {Σ} {wfΣ : wf Σ} {Γ t u} : +Lemma wt_red1_wt {cf} {Σ} {wfΣ : wf Σ} {Γ t u} : wt Σ Γ t -> red1 Σ Γ t u -> wt Σ Γ u. Proof. intros [s ht] r. @@ -2355,7 +2355,7 @@ Qed. Section wtcumul. Import PCUICAst PCUICTyping PCUICEquality. Context {cf : checker_flags}. - Record wt_red1 {cf} (Σ : PCUICEnvironment.global_env_ext) (Γ : PCUICEnvironment.context) T U := + Record wt_red1 {cf} (Σ : PCUICEnvironment.global_env_ext) (Γ : PCUICEnvironment.context) T U := { wt_red1_red1 : PCUICReduction.red1 Σ Γ T U; wt_red1_dom : wt Σ Γ T; wt_red1_codom : wt Σ Γ U }. @@ -2367,7 +2367,7 @@ Section wtcumul. | wt_cumul_red_l t u v : wt_red1 Σ Γ t v -> Σ ;;; Γ |-- v <=[pb] u -> Σ ;;; Γ |-- t <=[pb] u | wt_cumul_red_r t u v : Σ ;;; Γ |-- t <=[pb] v -> wt_red1 Σ Γ u v -> Σ ;;; Γ |-- t <=[pb] u where " Σ ;;; Γ |-- t <=[ pb ] u " := (wt_cumul_pb pb Σ Γ t u) : type_scope. - + Definition wt_cumul := wt_cumul_pb Cumul. Definition wt_conv := wt_cumul_pb Conv. @@ -2378,7 +2378,7 @@ Section wtcumul. Proof. move/isType_wt => ht. move/isType_wt => hu. - induction 1. + induction 1. - constructor. auto. - pose proof (wt_red ht r). econstructor 2. @@ -2395,7 +2395,7 @@ Section wtcumul. wt_cumul_pb Conv Σ Γ T U. Proof. intros ht hu. - induction 1. + induction 1. - constructor. auto. - pose proof (wt_red ht r). econstructor 2. @@ -2406,10 +2406,10 @@ Section wtcumul. econstructor; tea. Qed. - Definition wt_cumul_pb_ctx {cf} le Σ := + Definition wt_cumul_pb_ctx {cf} le Σ := All2_fold (fun Γ Γ' => All_decls_alpha_pb le (fun le => wt_cumul_pb le Σ Γ)). - Definition wt_cumul_pb_ctx_rel {cf} le Σ Γ := + Definition wt_cumul_pb_ctx_rel {cf} le Σ Γ := All2_fold (fun Δ Δ' => All_decls_alpha_pb le (fun le => wt_cumul_pb le Σ (Γ ,,, Δ))). End wtcumul. @@ -2419,16 +2419,16 @@ Lemma trans_conv {cf} {Σ : PCUICEnvironment.global_env_ext} {Γ T U} {wfΣ : PC wt_conv Σ Γ T U -> cumulAlgo_gen (H := cf' cf) (trans_global Σ) (trans_local Γ) Conv (trans T) (trans U). Proof. - intros wfΣ'; induction 1. + intros wfΣ'; induction 1. - constructor; auto. - red in c. + red in c. eapply trans_compare_term in c. now rewrite -trans_global_ext_constraints. - destruct w as [r ht hv]. apply trans_red1 in r; eauto. - eapply red_conv_conv; tea. + eapply red_conv_conv; tea. - destruct w as [r ht hv]. - apply trans_red1 in r; eauto. + apply trans_red1 in r; eauto. eapply red_conv_conv_inv; tea. Qed. @@ -2437,16 +2437,16 @@ Lemma trans_cumul {cf} {Σ : PCUICEnvironment.global_env_ext} {Γ T U} {wfΣ : P wt_cumul Σ Γ T U -> cumulAlgo_gen (H:=cf' cf) (trans_global Σ) (trans_local Γ) Cumul (trans T) (trans U). Proof. - intros wfΣ'; induction 1. + intros wfΣ'; induction 1. - constructor; auto. red in c. eapply trans_compare_term in c. now rewrite -trans_global_ext_constraints. - destruct w as [r ht hv]. apply trans_red1 in r; eauto. - eapply red_cumul_cumul; tea. + eapply red_cumul_cumul; tea. - destruct w as [r ht hv]. - apply trans_red1 in r; eauto. + apply trans_red1 in r; eauto. eapply red_cumul_cumul_inv; tea. Qed. @@ -2475,7 +2475,7 @@ Lemma trans_wf_local_env {cf} Σ Γ : (ST.lift_typing (fun (Σ : SE.global_env_ext) Γ b ty => wf_trans Σ -> - ST.typing Σ Γ b ty × + ST.typing Σ Γ b ty × TT.typing (H:=cf' cf) (trans_global Σ) (trans_local Γ) (trans b) (trans ty)) Σ) Γ -> wf_trans Σ -> @@ -2545,7 +2545,7 @@ Proof. - destruct t0 as (?&?&?). eexists;eassumption. - destruct t1. - assumption. + assumption. Qed. @@ -2578,8 +2578,8 @@ Proof. destruct t => //. Qed. -Lemma trans_decompose_app t : - let '(hd, args) := decompose_app t in +Lemma trans_decompose_app t : + let '(hd, args) := decompose_app t in decompose_app (trans t) = (trans hd, map trans args). Proof. destruct (decompose_app t) eqn:da. @@ -2613,16 +2613,16 @@ Proof. eapply IHl in e''. rewrite e''. now noconf e. Qed. -Lemma on_free_vars_it_mkProd_or_LetIn {P Δ t} : - on_free_vars P (it_mkProd_or_LetIn Δ t) = +Lemma on_free_vars_it_mkProd_or_LetIn {P Δ t} : + on_free_vars P (it_mkProd_or_LetIn Δ t) = on_free_vars_ctx P Δ && on_free_vars (shiftnP #|Δ| P) t. Proof. move: P. induction Δ using rev_ind => P. - cbn. now rewrite shiftnP0. - destruct x as [na [b|] ty]; rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=. - rewrite on_free_vars_ctx_app /= IHΔ !plengths /= shiftnP_add on_free_vars_ctx_tip /= + rewrite on_free_vars_ctx_app /= IHΔ !plengths /= shiftnP_add on_free_vars_ctx_tip /= /on_free_vars_decl /test_decl /=. ring. - rewrite on_free_vars_ctx_app /= IHΔ !lengths /= shiftnP_add on_free_vars_ctx_tip /= + rewrite on_free_vars_ctx_app /= IHΔ !lengths /= shiftnP_add on_free_vars_ctx_tip /= /on_free_vars_decl /test_decl /=. ring. Qed. @@ -2652,7 +2652,7 @@ Definition on_free_vars_mfix p n mfix := Lemma map_option_out_check_one_fix {p n mfix} : on_free_vars_mfix p n mfix -> - map (fun x => TT.check_one_fix (map_def trans trans x)) mfix = + map (fun x => TT.check_one_fix (map_def trans trans x)) mfix = map ST.check_one_fix mfix. Proof. move/forallb_All => hmfix. eapply All_map_eq, All_impl; tea; cbv beta. @@ -2672,7 +2672,7 @@ Proof. Qed. Lemma map_option_out_check_one_cofix mfix : - map (fun x => TT.check_one_cofix (map_def trans trans x)) mfix = + map (fun x => TT.check_one_cofix (map_def trans trans x)) mfix = map ST.check_one_cofix mfix. Proof. eapply map_ext => x. apply trans_check_one_cofix. @@ -2688,7 +2688,7 @@ Qed. Lemma trans_wf_fixpoint Σ p n mfix : on_free_vars_mfix p n mfix -> - TT.wf_fixpoint (trans_global_env Σ) (map (map_def trans trans) mfix) = + TT.wf_fixpoint (trans_global_env Σ) (map (map_def trans trans) mfix) = ST.wf_fixpoint Σ mfix. Proof. intros hmfix. @@ -2703,7 +2703,7 @@ Proof. Qed. Lemma trans_wf_cofixpoint Σ mfix : - TT.wf_cofixpoint (trans_global_env Σ) (map (map_def trans trans) mfix) = + TT.wf_cofixpoint (trans_global_env Σ) (map (map_def trans trans) mfix) = ST.wf_cofixpoint Σ mfix. Proof. unfold ST.wf_cofixpoint, TT.wf_cofixpoint. @@ -2737,7 +2737,7 @@ Axiom cofix_guard_trans : ST.cofix_guard Σ Γ mfix -> TT.cofix_guard (trans_global Σ) (trans_local Γ) (map (map_def trans trans) mfix). -Lemma trans_it_mkLambda_or_LetIn Γ T : +Lemma trans_it_mkLambda_or_LetIn Γ T : trans (it_mkLambda_or_LetIn Γ T) = it_mkLambda_or_LetIn (trans_local Γ) (trans T). Proof. induction Γ using rev_ind. @@ -2747,8 +2747,8 @@ Proof. destruct x as [na [b|] ty] => /=; cbn; now f_equal. Qed. -Lemma All2i_All2_mapi {A B C D} P (f : nat -> A -> B) (g : nat -> C -> D) l l' : - All2i (fun i x y => P (f i x) (g i y)) 0 l l' -> +Lemma All2i_All2_mapi {A B C D} P (f : nat -> A -> B) (g : nat -> C -> D) l l' : + All2i (fun i x y => P (f i x) (g i y)) 0 l l' -> All2 P (mapi f l) (mapi g l'). Proof. rewrite /mapi. generalize 0. @@ -2762,7 +2762,7 @@ Proof. induction 1; constructor; auto. Qed. -Lemma eq_names_subst_context_pcuic nas Γ s k : +Lemma eq_names_subst_context_pcuic nas Γ s k : eq_names nas Γ -> eq_names nas (subst_context s k Γ). Proof. @@ -2771,7 +2771,7 @@ Proof. * rewrite subst_context_snoc. constructor; auto. Qed. -Lemma eq_names_subst_instance_pcuic nas (Γ : context) u : +Lemma eq_names_subst_instance_pcuic nas (Γ : context) u : eq_names nas Γ -> eq_names nas (subst_instance u Γ). Proof. @@ -2780,7 +2780,7 @@ Proof. * rewrite /subst_instance /=. constructor; auto. Qed. -Lemma map_expand_lets_lift_cancel Γ n ts : +Lemma map_expand_lets_lift_cancel Γ n ts : n = #|Γ| -> map (expand_lets Γ) (map (lift0 n) ts) = map (lift0 (context_assumptions Γ)) ts. @@ -2789,8 +2789,8 @@ Proof. intros x. now rewrite expand_lets_lift_cancel. Qed. -Lemma expand_lets_k_subst_comm Δ k s T : - expand_lets_k Δ k (subst s k T) = +Lemma expand_lets_k_subst_comm Δ k s T : + expand_lets_k Δ k (subst s k T) = subst (map (expand_lets Δ) s) k (expand_lets_k Δ (#|s| + k) T). Proof. rewrite /expand_lets_k. @@ -2800,7 +2800,7 @@ Proof. rewrite map_map_compose. reflexivity. Qed. -Lemma context_assumptions_set_binder_name nas Γ : +Lemma context_assumptions_set_binder_name nas Γ : #|nas| = #|Γ| -> context_assumptions (map2 set_binder_name nas Γ) = context_assumptions Γ. Proof. @@ -2808,10 +2808,10 @@ Proof. intros [=]. destruct c as [na [b|] ty]; cbn; auto. rewrite IHnas //. Qed. - -Lemma extended_subst_set_binder_name nas Γ k : + +Lemma extended_subst_set_binder_name nas Γ k : #|nas| = #|Γ| -> - extended_subst (map2 set_binder_name nas Γ) k = + extended_subst (map2 set_binder_name nas Γ) k = extended_subst Γ k. Proof. induction nas in Γ, k |- *; destruct Γ; cbn => //. @@ -2820,7 +2820,7 @@ Proof. rewrite IHnas //. rewrite context_assumptions_set_binder_name //. Qed. -Lemma expand_lets_set_binder_name nas Γ t : +Lemma expand_lets_set_binder_name nas Γ t : #|nas| = #|Γ| -> expand_lets (map2 set_binder_name nas Γ) t = expand_lets Γ t. Proof. @@ -2831,7 +2831,7 @@ Proof. !context_assumptions_set_binder_name //. Qed. -Lemma expand_lets_k_lift n k k' Γ t : +Lemma expand_lets_k_lift n k k' Γ t : expand_lets_k (lift_context n k Γ) k' (lift n (#|Γ| + k + k') t) = lift n (k + k' + context_assumptions Γ) (expand_lets_k Γ k' t). Proof. @@ -2844,7 +2844,7 @@ Proof. now len. Qed. -Lemma lift_expand_lets_k Δ Γ t : +Lemma lift_expand_lets_k Δ Γ t : closed_ctx Γ -> on_free_vars (shiftnP (#|Γ| + #|Δ|) xpred0) t -> lift (context_assumptions Δ) #|Δ| (expand_lets_k Γ #|Δ| t) = @@ -2902,8 +2902,8 @@ Proof. now depelim ass. now depelim ass'. Qed. -Lemma on_free_vars_subst_k s k t : - forallb (on_free_vars xpred0) s -> +Lemma on_free_vars_subst_k s k t : + forallb (on_free_vars xpred0) s -> on_free_vars (shiftnP (#|s| + k) xpred0) t -> on_free_vars (shiftnP k xpred0) (subst s k t). Proof. @@ -2914,7 +2914,7 @@ Proof. nat_compare_specs => //. Qed. -Lemma on_free_vars_expand_lets_k P Γ k t : +Lemma on_free_vars_expand_lets_k P Γ k t : on_free_vars_ctx P Γ -> on_free_vars (shiftnP (k + #|Γ|) P) t -> on_free_vars (shiftnP (k + context_assumptions Γ) P) (expand_lets_k Γ k t). @@ -2928,7 +2928,7 @@ Proof. - len. rewrite /substP /= /strengthenP /=. intros i. simpl. rewrite /shiftnP. repeat nat_compare_specs => /= //. - rewrite Nat.sub_0_r. + rewrite Nat.sub_0_r. replace (i + #|Γ| - context_assumptions Γ - (k + #|Γ|)) with (i - context_assumptions Γ - k) by lia. rewrite /occ_betweenP. repeat nat_compare_specs => /= //. rewrite orb_false_r. @@ -2988,7 +2988,7 @@ Proof. intros h. now rewrite forget_types_map_context. } rewrite /case_branch_type /case_branch_type_gen /=. set (brctx' := case_branch_context_gen _ _ _ _ _ _). - have eqbrctx' : brctx' = trans_local (smash_context [] + have eqbrctx' : brctx' = trans_local (smash_context [] (case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl)). { rewrite /brctx' [case_branch_context_gen _ _ _ _ _ _](trans_inst_case_branch_context (Γ := Γ) @@ -2999,7 +2999,7 @@ Proof. rewrite !map_app (map_map_compose _ _ _ _ trans). f_equal. { relativize #|cstr_args cdecl|. erewrite expand_lets_lift_cancel. 2:rewrite case_branch_context_length_args //. - rewrite case_branch_context_assumptions //. + rewrite case_branch_context_assumptions //. rewrite (trans_lift _ (shiftnP #|Γ| xpred0)). { rewrite /ptm on_free_vars_it_mkLambda_or_LetIn. apply/andP; split. @@ -3011,7 +3011,7 @@ Proof. { pose proof (declared_constructor_closed_args declc). now eapply closedn_ctx_on_free_vars. } f_equal. - rewrite !map_map_compose /id. + rewrite !map_map_compose /id. pose proof (declared_constructor_closed_indices declc). eapply forallb_All in H. eapply All_map_eq. eapply All_impl; tea; cbv beta. @@ -3020,7 +3020,7 @@ Proof. rewrite shiftnP_add. eapply closedn_on_free_vars. red in cl. red. rewrite -cl. f_equal. lia. - rewrite -trans_inds. + rewrite -trans_inds. rewrite -trans_subst_instance. have fvsexpx : on_free_vars (shiftnP (context_assumptions (cstr_args cdecl)) @@ -3083,7 +3083,7 @@ Proof. rewrite instantiate_inds //. exact declc. 4:now len. 4:now len. now rewrite Nat.add_comm. rewrite closedn_subst_instance_context. eauto with pcuic. len. eapply on_free_vars_subst_k. eapply (inds_is_open_terms []). - len. rewrite on_free_vars_subst_instance. + len. rewrite on_free_vars_subst_instance. eapply closedn_on_free_vars. rewrite Nat.add_assoc //. } cbn. f_equal. rewrite -(trans_smash_context (shiftnP (#|ind_bodies mdecl| + #|ind_params mdecl|) xpred0) []) //. @@ -3112,13 +3112,13 @@ Proof. simpl. rewrite app_length /= => Hlen. unfold arities_context. simpl. rewrite /arities_context rev_map_spec /=. - rewrite map_app /= rev_app_distr /=. + rewrite map_app /= rev_app_distr /=. rewrite /= Nat.add_1_r /=. constructor. rewrite -rev_map_spec. apply IHl. lia. Qed. -Lemma ws_cumul_pb_it_mkProd_or_LetIn_smash {cf} {Σ : global_env_ext} {wfΣ : wf Σ} Γ Δ T : +Lemma ws_cumul_pb_it_mkProd_or_LetIn_smash {cf} {Σ : global_env_ext} {wfΣ : wf Σ} Γ Δ T : is_closed_context Γ -> is_open_term Γ (it_mkProd_or_LetIn Δ T) -> Σ ;;; Γ ⊢ it_mkProd_or_LetIn Δ T = it_mkProd_or_LetIn (smash_context [] Δ) (expand_lets Δ T). Proof. @@ -3135,7 +3135,7 @@ Proof. induction Δ in Γ, T |- * using ctx_length_rev_ind. - cbn. rewrite expand_lets_nil. reflexivity. - rewrite it_mkProd_or_LetIn_app. - destruct d as [na [b|] ty]; cbn; [rewrite smash_context_app_def expand_lets_vdef|rewrite smash_context_app_ass expand_lets_vass]. + destruct d as [na [b|] ty]; cbn; [rewrite smash_context_app_def expand_lets_vdef|rewrite smash_context_app_ass expand_lets_vass]. * etransitivity. eapply red1_red. constructor. rewrite /subst1 subst_it_mkProd_or_LetIn Nat.add_0_r. @@ -3144,8 +3144,8 @@ Proof. eapply red_prod. reflexivity. now eapply X. Qed. - -Lemma map_expand_lets_to_extended_list_k_above Γ Δ : + +Lemma map_expand_lets_to_extended_list_k_above Γ Δ : map (expand_lets Γ) (to_extended_list_k Δ #|Γ|) = to_extended_list_k Δ (context_assumptions Γ). Proof. unfold to_extended_list_k. @@ -3156,7 +3156,7 @@ Proof. rewrite -reln_lift Nat.add_0_r //. Qed. -Lemma on_free_vars_to_extended_list_k P ctx k : +Lemma on_free_vars_to_extended_list_k P ctx k : forallb (on_free_vars (shiftnP (k + #|ctx|) P)) (to_extended_list_k ctx k). Proof. rewrite /to_extended_list /to_extended_list_k. @@ -3181,8 +3181,8 @@ Lemma trans_type_of_constructor {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {wfΣ' consistent_instance_ext (trans_global Σ) (ind_universes (trans_minductive_body mdecl)) u -> ws_cumul_pb (cf := cf' cf) Conv (trans_global Σ) [] (trans (ST.type_of_constructor mdecl cdecl (ind, i) u)) - (TT.type_of_constructor - (trans_minductive_body mdecl) + (TT.type_of_constructor + (trans_minductive_body mdecl) (trans_constructor_body (inductive_ind ind) mdecl cdecl) (ind,i) u). @@ -3233,7 +3233,7 @@ Proof. rewrite shiftnP_add. len. rewrite /cstr_concl. rewrite subst_instance_mkApps on_free_vars_mkApps /=. rewrite forallb_map forallb_app. apply/and3P; split. - rewrite /shiftnP orb_false_r. apply Nat.ltb_lt. + rewrite /shiftnP orb_false_r. apply Nat.ltb_lt. assert (#|ind_bodies mdecl| > 0). { destruct oncstr as [[] ?]. clear hnth. eapply nth_error_Some_length in e. lia. } lia. @@ -3259,8 +3259,8 @@ Proof. rewrite !subst_instance_mkApps !trans_mkApps. rewrite expand_lets_mkApps. f_equal. rewrite /trans_cstr_concl_head. len. - rewrite /cstr_concl_head /=. - relativize #|cstr_args cdecl|. erewrite expand_lets_tRel. + rewrite /cstr_concl_head /=. + relativize #|cstr_args cdecl|. erewrite expand_lets_tRel. cbn. rewrite !context_assumptions_map context_assumptions_subst_instance //. now len. rewrite !map_app. f_equal. @@ -3285,11 +3285,11 @@ Proof. rewrite on_free_vars_it_mkProd_or_LetIn. len. cbn. rewrite on_free_vars_ctx_smash //. - rewrite -closedP_shiftnP. + rewrite -closedP_shiftnP. rewrite on_free_vars_ctx_subst_instance. eapply on_free_vars_ctx_trans. eapply closedn_ctx_on_free_vars. now rewrite Nat.add_comm. - cbn. + cbn. eapply PCUICOnFreeVars.on_free_vars_expand_lets_k. now len. rewrite Nat.add_comm on_free_vars_ctx_subst_instance. eapply on_free_vars_ctx_trans. @@ -3299,7 +3299,7 @@ Proof. move/andP => [] _. now len. Qed. -Lemma trans_eq_annots (Γ : list aname) Δ : +Lemma trans_eq_annots (Γ : list aname) Δ : eq_annots Γ Δ -> eq_annots Γ (trans_local Δ). Proof. @@ -3321,7 +3321,7 @@ Proof. constructor. cbn. auto. now apply trans_eq_annots. Qed. - + Lemma extends_trans {Σ Σ' : global_env} : extends Σ Σ' -> extends (trans_global_env Σ) (trans_global_env Σ'). Proof. intros [onu [Σ'' eq]]. @@ -3329,7 +3329,7 @@ Proof. rewrite /= eq /trans_global_decls /= map_app //. Qed. -Lemma extends_decls_trans {Σ Σ' : global_env} : extends_decls Σ Σ' -> +Lemma extends_decls_trans {Σ Σ' : global_env} : extends_decls Σ Σ' -> extends_decls (trans_global_env Σ) (trans_global_env Σ'). Proof. intros [onu [Σ'' eq]]. @@ -3349,16 +3349,16 @@ Proof. pose proof (extends_decls_trans ext). assert (wfΣ := extends_decls_wf _ _ Hw X). eapply (weakening_env (trans_global (Σ, u))); eauto. tc. - + - intros [s Hs]. exists s. intros Hw. pose proof (extends_decls_trans ext). - pose proof (extends_decls_wf _ _ Hw X). + pose proof (extends_decls_wf _ _ Hw X). specialize (Hs X0). eapply (weakening_env (trans_global (Σ, u))); eauto. tc. Qed. Lemma trans_arities_context mdecl : - arities_context (ind_bodies (trans_minductive_body mdecl)) = + arities_context (ind_bodies (trans_minductive_body mdecl)) = trans_local (arities_context (ind_bodies mdecl)). Proof. rewrite /arities_context. @@ -3370,7 +3370,7 @@ Qed. Lemma trans_subst_telescope p q s n Γ : on_free_vars_terms p s -> on_free_vars_ctx q (List.rev Γ) -> - trans_local (subst_telescope s n Γ) = + trans_local (subst_telescope s n Γ) = subst_telescope (map trans s) n (trans_local Γ). Proof. induction Γ in s, n, q|- *. @@ -3399,18 +3399,18 @@ Proof. eapply eq_annots_lift_context. Qed. -(** We need to go through the intermediate definition which just maps the translation +(** We need to go through the intermediate definition which just maps the translation on inductive declarations but does not perform smashing of the arguments contexts. *) Definition map_trans_constructor_body (d : PCUICEnvironment.constructor_body) := let args := trans_local d.(cstr_args) in let indices := map trans d.(cstr_indices) in - {| cstr_name := d.(PCUICEnvironment.cstr_name); + {| cstr_name := d.(PCUICEnvironment.cstr_name); cstr_args := args; cstr_indices := indices; cstr_type := trans d.(cstr_type); cstr_arity := d.(PCUICEnvironment.cstr_arity) |}. - + Definition map_trans_one_ind_body (d : PCUICEnvironment.one_inductive_body) := {| ind_name := d.(PCUICEnvironment.ind_name); ind_relevance := d.(PCUICEnvironment.ind_relevance); @@ -3471,9 +3471,9 @@ Proof. rewrite trans_subst_instance_ctx. rewrite (trans_expand_lets_ctx xpred0 (shiftnP #|ind_params mdecl| xpred0)); eauto with pcuic. f_equal. f_equal. - rewrite (trans_subst_context + rewrite (trans_subst_context (shiftnP (#|ind_bodies mdecl| + #|ind_params mdecl|) xpred0) xpred0) //. - eapply (inds_is_open_terms []). + eapply (inds_is_open_terms []). f_equal. rewrite trans_inds //. cbn. now len. now len. rewrite /br'. cbn [bcontext map_branch]. eapply alpha_eq_trans in onbctx. @@ -3481,14 +3481,14 @@ Proof. rewrite /cstr_branch_context. rewrite (trans_expand_lets_ctx xpred0 (shiftnP #|ind_params mdecl| xpred0)) //. eauto with pcuic. rewrite (trans_subst_context (shiftnP (#|ind_bodies mdecl| + #|ind_params mdecl|) xpred0) xpred0) //. - eapply (inds_is_open_terms []). + eapply (inds_is_open_terms []). rewrite trans_inds. len. cbn [cstr_args map_trans_constructor_body]. cbn [ind_params map_trans_minductive_body]. cbn [ind_universes map_trans_minductive_body]. rewrite /inds. len. reflexivity. Qed. - + Lemma All_over_All {cf} Σ Γ wfΓ : ST.All_local_env_over ST.typing (fun (Σ : SE.global_env_ext) (Γ : SE.context) @@ -3524,7 +3524,7 @@ Qed. Theorem pcuic_expand_lets {cf} (Σ : SE.global_env_ext) Γ t T : wf Σ -> typing Σ Γ t T -> - wf_trans Σ -> + wf_trans Σ -> typing (H:=cf' cf) (trans_global Σ) (trans_local Γ) (trans t) (trans T). Proof. intros X X0. @@ -3533,7 +3533,7 @@ Proof. wf_trans Σ -> TT.typing (H:=cf' cf) (trans_global Σ) (trans_local Γ) (trans t) (trans T) )%type - (fun Σ Γ => + (fun Σ Γ => wf_trans Σ -> TT.All_local_env (TT.lift_typing (TT.typing (H:=cf' cf)) (trans_global Σ)) (trans_local Γ)) );intros. @@ -3567,7 +3567,7 @@ Proof. + now apply trans_consistent_instance_ext. - eapply (type_ws_cumul_pb (pb:=Conv)). eapply TT.type_Construct. eauto. - + eapply trans_declared_constructor in isdecl; tea. + + eapply trans_declared_constructor in isdecl; tea. + now apply trans_consistent_instance_ext. + red in X. epose proof (declared_constructor_inv_decls weaken_prop _ X isdecl) as [cs [hnth onc]]. destruct onc. red in on_ctype. @@ -3611,7 +3611,7 @@ Proof. + now eapply trans_wf_predicate. + cbn [pparams pcontext]. rewrite (trans_case_predicate_context (Σ := Σ) (Γ := Γ)); tea. - now rewrite -trans_local_app. + now rewrite -trans_local_app. + rewrite -trans_ind_predicate_context; eauto with pcuic. now eapply alpha_eq_trans. + rewrite <- trans_global_ext_constraints. @@ -3635,7 +3635,7 @@ Proof. * intros Γ l wf. intros c; depelim c. constructor. * intros Δ. rewrite app_context_assoc. - rewrite List.rev_app_distr /=. + rewrite List.rev_app_distr /=. move=> l wfctx. intros H. depelim H. { depelim IHctxi. @@ -3647,14 +3647,14 @@ Proof. rewrite subst_telescope_subst_context in IHctxi. specialize (X IHctxi). rewrite -subst_telescope_subst_context in X. - rewrite [map trans_decl _](trans_subst_telescope (shiftnP #|Δ| xpred0) + rewrite [map trans_decl _](trans_subst_telescope (shiftnP #|Δ| xpred0) (shiftnP (S #|Δ|) xpred0)) in X. cbn. rewrite (subject_is_open_term t0) //. rewrite List.rev_involutive. eapply wf_local_closed_context in wfctx. now move: wfctx; rewrite on_free_vars_ctx_app /= => /andP[]. exact X. } - { intros c; depelim c. - constructor. + { intros c; depelim c. + constructor. destruct (wf_local_app_inv wfctx) as [w _]. depelim w. unshelve epose proof (substitution_wf_local (Γ':=[vdef na b t]) _ wfctx). shelve. { now eapply subslet_def_tip. } @@ -3663,7 +3663,7 @@ Proof. rewrite subst_telescope_subst_context in c. specialize (X c). rewrite -subst_telescope_subst_context in X. - rewrite [map trans_decl _](trans_subst_telescope (shiftnP #|Δ| xpred0) + rewrite [map trans_decl _](trans_subst_telescope (shiftnP #|Δ| xpred0) (shiftnP (S #|Δ|) xpred0)) in X. cbn. rewrite (subject_is_open_term l1) //. rewrite List.rev_involutive. eapply wf_local_closed_context in wfctx. @@ -3687,7 +3687,7 @@ Proof. eapply (eq_annots_expand_lets_ctx _ (trans_local (ind_params mdecl))). rewrite -(smash_context_subst []) /= subst_context_nil. rewrite (expand_lets_smash_context _ []) /=. len; rewrite expand_lets_k_ctx_nil. - rewrite (trans_expand_lets_ctx xpred0 (shiftnP #|ind_params mdecl| xpred0)) in cd. + rewrite (trans_expand_lets_ctx xpred0 (shiftnP #|ind_params mdecl| xpred0)) in cd. eauto with pcuic. { eapply on_free_vars_ctx_subst_context. len. apply closedn_ctx_on_free_vars. @@ -3720,7 +3720,7 @@ Proof. rewrite (trans_case_predicate_context declc H1 s H0). intros brctxty. have trbr := !! (trans_case_branch_type (Γ := Γ) declc H1 H0 wf X1 eqctx). - forward_keep trbr. + forward_keep trbr. { eassert (ctx_inst _ _ _ _) as Hctxi by (eapply ctx_inst_impl with (1 := X5); now intros ? []). eapply ctx_inst_open_terms in Hctxi. eapply All_app in Hctxi as []. @@ -3757,7 +3757,7 @@ Proof. rewrite -/(inst_case_context (pparams p') (puinst p') _). cbn -[inst_case_context expand_lets]. f_equal. rewrite /cbctx. - rewrite (trans_case_branch_context (Γ := Γ) declc) //. } + rewrite (trans_case_branch_context (Γ := Γ) declc) //. } eapply (typing_expand_lets (Σ := trans_global Σ)). now rewrite trans_local_app in IHb. * rewrite eqbrctx' eqbrty'. @@ -3791,7 +3791,7 @@ Proof. + rewrite /trans_local map_app in X. now eapply TT.All_local_env_app_inv in X as []. + now apply fix_guard_trans. - + erewrite map_nth_error. + + erewrite map_nth_error. 2: apply H0. destruct decl. unfold map_def. @@ -3828,7 +3828,7 @@ Proof. + fold trans. eapply All_map, (All_impl X0). intros x [s ?]; exists s; intuition auto. - + fold trans;subst types. + + fold trans;subst types. eapply All_map. eapply All_prod in X0; tea. clear X1. eapply All_impl; tea. intros d [[Hdb IHdb] [hs [hdty ihdty]]]. @@ -3859,7 +3859,7 @@ Proof. now eapply subject_is_open_term in X3. Qed. -Lemma fresh_global_map {kn} {Σ : global_env} : +Lemma fresh_global_map {kn} {Σ : global_env} : fresh_global kn Σ.(declarations) -> fresh_global kn (trans_global_decls Σ.(declarations)). Proof. intros f. @@ -3907,7 +3907,7 @@ Proof. rewrite expand_lets_vass. cbn. rewrite -[_ ,, _](app_context_assoc _ _ [_]). apply X. Qed. -Lemma subst_context_expand_lets_ctx Δ s Δ' : +Lemma subst_context_expand_lets_ctx Δ s Δ' : subst_context (map (expand_lets Δ) s) 0 (expand_lets_k_ctx Δ #|s| Δ') = expand_lets_ctx Δ (subst_context s 0 Δ'). Proof. @@ -3948,7 +3948,7 @@ Proof. f_equal; eauto. Qed. -Lemma trans_local_subst_telescope p q s k Γ : +Lemma trans_local_subst_telescope p q s k Γ : on_free_vars_ctx p (List.rev Γ) -> on_free_vars_terms q s -> trans_local (subst_telescope s k Γ) = subst_telescope (map trans s) k (trans_local Γ). @@ -3964,7 +3964,7 @@ Lemma trans_ctx_inst_expand_lets {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ wf_trans Σ -> wf_local Σ (Γ ,,, List.rev Δ) -> PCUICTyping.ctx_inst (λ (Σ : global_env_ext) (Γ : context) (t T : term), Σ;;; Γ |- t : T) Σ Γ s Δ -> - PCUICTyping.ctx_inst (λ (Σ : global_env_ext) (Γ : context) (t T : term), + PCUICTyping.ctx_inst (λ (Σ : global_env_ext) (Γ : context) (t T : term), typing (H:=cf' cf) Σ Γ t T) (trans_global Σ) (trans_local Γ) (map trans s) (trans_local Δ). Proof. @@ -3975,7 +3975,7 @@ Proof. cbn in wfctx. rewrite -app_assoc in wfctx. unshelve epose proof (substitution_wf_local (Σ := Σ) (Γ' := [vass na t]) _ wfctx). shelve. { now eapply subslet_ass_tip. } - rewrite subst_context_subst_telescope in X. specialize (IHi X). + rewrite subst_context_subst_telescope in X. specialize (IHi X). rewrite (trans_local_subst_telescope (shiftnP (S #|Γ|) xpred0) (shiftnP #|Γ| xpred0)) in IHi. { apply wf_local_closed_context in wfctx. now move/onfvs_app: wfctx => /=. } @@ -3986,7 +3986,7 @@ Proof. unshelve epose proof (substitution_wf_local (Σ := Σ) (Γ' := [vdef na b t]) _ wfctx). shelve. { eapply subslet_def_tip. eapply wf_local_app_inv in wfctx as [wf' _]. now depelim wf'. } - rewrite subst_context_subst_telescope in X. specialize (IHi X). + rewrite subst_context_subst_telescope in X. specialize (IHi X). rewrite (trans_local_subst_telescope (shiftnP (S #|Γ|) xpred0) (shiftnP #|Γ| xpred0)) in IHi. { apply wf_local_closed_context in wfctx. now move/onfvs_app: wfctx => /=. } @@ -4000,7 +4000,7 @@ Lemma expand_lets_ctx_lift_context_cancel {Γ Δ} : lift_context (context_assumptions Γ) 0 Δ. Proof. rewrite /expand_lets_ctx /expand_lets_k_ctx /=. - rewrite (lift_context_lift_context _ 0) Nat.add_comm lift_context_add. + rewrite (lift_context_lift_context _ 0) Nat.add_comm lift_context_add. rewrite subst_context_lift_context_cancel //. now len. Qed. @@ -4020,7 +4020,7 @@ Proof. now intros x y ->. Qed. -Lemma Alli_nth_hyp_ind {A} {P : nat -> A -> Type} {n l} : +Lemma Alli_nth_hyp_ind {A} {P : nat -> A -> Type} {n l} : Alli P n l -> Alli (fun i x => (n <= i) * (nth_error l (i - n) = Some x) * P i x) n l. Proof. @@ -4033,7 +4033,7 @@ Proof. cbn in b0. rewrite Nat.sub_succ_l //; lia. Qed. -Lemma Alli_nth_hyp {A} {P : nat -> A -> Type} {l} : +Lemma Alli_nth_hyp {A} {P : nat -> A -> Type} {l} : Alli P 0 l -> Alli (fun i x => (nth_error l i = Some x) * P i x) 0 l. Proof. @@ -4057,7 +4057,7 @@ Lemma trans_cstr_concl_eq m n cdecl : Proof. intros onargs onindices. rewrite /trans_cstr_concl /cstr_concl trans_mkApps expand_lets_mkApps. - f_equal. + f_equal. { rewrite /trans_cstr_concl_head /cstr_concl_head. len. cbn [trans]. relativize #|cstr_args cdecl|. @@ -4068,7 +4068,7 @@ Proof. { rewrite trans_reln /=. rewrite -trans_to_extended_list. rewrite -/(to_extended_list_k (trans_local (ind_params m)) #|cstr_args cdecl|). - relativize #|cstr_args cdecl|. + relativize #|cstr_args cdecl|. erewrite map_expand_lets_to_extended_list_k_above. 2:now len. rewrite context_assumptions_map. rewrite trans_to_extended_list //. } @@ -4082,7 +4082,7 @@ Lemma positive_cstr_smash_middle m n acc Γ Δ T : Proof. revert Δ acc T. induction Γ using ctx_length_rev_ind. cbn. - - intros Δ. induction Δ using ctx_length_rev_ind. + - intros Δ. induction Δ using ctx_length_rev_ind. { cbn; auto. intros; rewrite expand_lets_nil //. } intros acc T. rewrite !it_mkProd_or_LetIn_app. destruct d as [na [b|] ty]. @@ -4090,14 +4090,14 @@ Proof. rewrite smash_context_app_def. intros p. depelim p. solve_discr. rewrite expand_lets_vdef. - eapply X. now len. + eapply X. now len. rewrite subst_it_mkProd_or_LetIn Nat.add_0_r in p => //. * rewrite smash_context_app_ass expand_lets_vass. rewrite it_mkProd_or_LetIn_app /=. intros p; depelim p. solve_discr. cbn in *. constructor 3; auto. - - intros Δ acc T. destruct d as [na [b|] ty]; rewrite !it_mkProd_or_LetIn_app /=; intros p; depelim p; + - intros Δ acc T. destruct d as [na [b|] ty]; rewrite !it_mkProd_or_LetIn_app /=; intros p; depelim p; try solve_discr. * constructor. rewrite !subst_it_mkProd_or_LetIn. len => /=. rewrite -(expand_lets_subst_comm _ _ _ _). @@ -4110,10 +4110,10 @@ Qed. Lemma closedn_trans n t : closedn n t -> closedn n (trans t). Proof. intros cl; rewrite on_free_vars_closedn. eapply trans_on_free_vars. - now rewrite -on_free_vars_closedn. + now rewrite -on_free_vars_closedn. Qed. -Lemma trans_destArity ctx t : +Lemma trans_destArity ctx t : destArity (trans_local ctx) (trans t) = match destArity ctx t with | Some (ctx, T) => Some (trans_local ctx, T) | None => None @@ -4129,7 +4129,7 @@ Lemma trans_ind_realargs m k i : Proof. unfold ind_realargs. rewrite (trans_destArity []). - destruct destArity => //. destruct p. + destruct destArity => //. destruct p. now len. Qed. @@ -4142,12 +4142,12 @@ Proof. - intros ont. constructor; len. now eapply closedn_trans. - rewrite on_free_vars_mkApps => /= /andP[] onk onl. - rewrite trans_mkApps. econstructor 2. now len. now len. + rewrite trans_mkApps. econstructor 2. now len. now len. solve_all. len. now eapply closedn_trans. len. cbn. rewrite rev_mapi. rewrite nth_error_mapi e /= //. len. now rewrite -trans_ind_realargs. - cbn. move/and3P => [] onb onty ont. - constructor 3. + constructor 3. rewrite (trans_subst (shiftnP 1 p) p) in IHX => /= //. now rewrite onb. eapply IHX. eapply on_free_vars_subst => /= //. now erewrite onb. @@ -4176,7 +4176,7 @@ Proof. - cbn. move/andP=> [] onty ont. constructor. now eapply positive_cstr_arg_trans. now eapply IHX. -Qed. +Qed. Lemma cumul_context_Spec_Algo {cf:checker_flags} {Σ} {wfΣ : wf Σ.1} {Γ Γ'} : wf_local Σ Γ -> @@ -4266,7 +4266,7 @@ Proof. induction 1; cbn; constructor; auto. eapply IHX. now depelim wfl. now depelim wfr. destruct p; constructor; cbn in *; auto. - - rewrite -trans_local_app. + - rewrite -trans_local_app. depelim wfl; depelim wfr. red in l, l0. destruct l0 as [s Hs]. destruct l as [s' Hs']. eapply trans_cumulSpec in eqt; tea. @@ -4275,7 +4275,7 @@ Proof. eapply All2_fold_app. reflexivity. apply X. } - rewrite -trans_local_app. depelim wfl; depelim wfr. red in l, l0. eapply (trans_convSpec (Σ := Σ)) => //. - now exists t. + now exists t. { red in l2. exists t'. eapply context_cumulativity_spec; tea. eapply All2_fold_app. reflexivity. apply X. } - rewrite -trans_local_app. @@ -4318,17 +4318,17 @@ Qed. Section wtcumul'. Import PCUICAst PCUICTyping PCUICEquality. Context {cf : checker_flags}. - + Reserved Notation " Σ ;;; Γ | Γ' |-- t <=[ le ] u " (at level 50, Γ, Γ' , le, t, u at next level). Inductive wt_cumul_pb_hetero (pb : conv_pb) (Σ : global_env_ext) (Γ Γ' : context) : term -> term -> Type := | wt_cumul_refl' t u : wt Σ Γ t -> wt Σ Γ' u -> - compare_term pb Σ.1 (global_ext_constraints Σ) t u -> Σ ;;; Γ | Γ' |-- t <=[pb] u + compare_term pb Σ.1 (global_ext_constraints Σ) t u -> Σ ;;; Γ | Γ' |-- t <=[pb] u | wt_cumul_red_l' t u v : wt_red1 Σ Γ t v -> Σ ;;; Γ | Γ' |-- v <=[pb] u -> Σ ;;; Γ | Γ' |-- t <=[pb] u | wt_cumul_red_r' t u v : Σ ;;; Γ | Γ' |-- t <=[pb] v -> wt_red1 Σ Γ' u v -> Σ ;;; Γ | Γ' |-- t <=[pb] u where " Σ ;;; Γ | Γ' |-- t <=[ le ] u " := (wt_cumul_pb_hetero le Σ Γ Γ' t u) : type_scope. - - Lemma wt_cumul_pb_hetero_inv {le Σ Γ Γ' T U} : + + Lemma wt_cumul_pb_hetero_inv {le Σ Γ Γ' T U} : wt_cumul_pb_hetero le Σ Γ Γ' T U -> wt Σ Γ T × wt Σ Γ' U. Proof. @@ -4342,14 +4342,14 @@ Section wtcumul'. isType Σ Γ T -> isType Σ Γ' U -> #|Γ| = #|Γ'| -> assumption_context Γ -> - assumption_context Γ' -> + assumption_context Γ' -> cumulAlgo Σ Γ T U -> wt_cumul_pb_hetero Cumul Σ Γ Γ' T U. Proof. move/isType_wt => ht. move/isType_wt => hu. move=> hlen ass ass'. - induction 1. + induction 1. - constructor; auto. - pose proof (wt_red ht r). econstructor 2. @@ -4377,13 +4377,13 @@ Section wtcumul'. wt Σ Γ T -> wt Σ Γ' U -> #|Γ| = #|Γ'| -> assumption_context Γ -> - assumption_context Γ' -> + assumption_context Γ' -> convSpec Σ Γ T U -> wt_cumul_pb_hetero Conv Σ Γ Γ' T U. Proof. move=> ht hu hlen ass ass' c. eapply wt_convSpec_convAlgo in c; tea. - induction c. + induction c. - constructor; auto. - pose proof (wt_red ht r). econstructor 2. @@ -4397,7 +4397,7 @@ Section wtcumul'. Qed. End wtcumul'. -Lemma pres_let_bodies_trans Γ Γ' : +Lemma pres_let_bodies_trans Γ Γ' : All2_fold (fun _ _ => pres_let_bodies) Γ Γ' -> All2_fold (fun _ _ => pres_let_bodies) (trans_local Γ) (trans_local Γ'). Proof. @@ -4411,25 +4411,25 @@ Lemma trans_cumul' {cf} {Σ : PCUICEnvironment.global_env_ext} {Γ Γ' T U} {wf wt_cumul_hetero Σ Γ Γ' T U -> #|Γ| = #|Γ'| -> assumption_context Γ -> - assumption_context Γ' -> + assumption_context Γ' -> cumulAlgo_gen (H:=cf' cf) (trans_global Σ) (trans_local Γ) Cumul (trans T) (trans U). Proof. - intros wfΣ'; induction 1. + intros wfΣ'; induction 1. - constructor; auto. - red in c. + red in c. eapply trans_compare_term in c. now rewrite -trans_global_ext_constraints. - destruct w as [r ht hv]. intros. apply trans_red1 in r; eauto. - eapply red_cumul_cumul; eauto. + eapply red_cumul_cumul; eauto. - destruct w as [r ht hv]. apply trans_red1 in r; eauto. intros. eapply context_pres_let_bodies_red in r. intros; eapply red_cumul_cumul_inv; eauto. eapply pres_let_bodies_trans; tea. - eapply pres_let_bodies_assumption_context; tea. now symmetry. + eapply pres_let_bodies_assumption_context; tea. now symmetry. Qed. Lemma trans_conv' {cf} {Σ : PCUICEnvironment.global_env_ext} {Γ Γ' T U} {wfΣ : PCUICTyping.wf Σ} : @@ -4437,25 +4437,25 @@ Lemma trans_conv' {cf} {Σ : PCUICEnvironment.global_env_ext} {Γ Γ' T U} {wfΣ wt_conv_hetero Σ Γ Γ' T U -> #|Γ| = #|Γ'| -> assumption_context Γ -> - assumption_context Γ' -> + assumption_context Γ' -> cumulAlgo_gen (H:=cf' cf) (trans_global Σ) (trans_local Γ) Conv (trans T) (trans U). Proof. - intros wfΣ'; induction 1. + intros wfΣ'; induction 1. - constructor; auto. - red in c. + red in c. eapply trans_compare_term in c. now rewrite -trans_global_ext_constraints. - destruct w as [r ht hv]. intros. apply trans_red1 in r; eauto. - eapply red_conv_conv; eauto. + eapply red_conv_conv; eauto. - destruct w as [r ht hv]. apply trans_red1 in r; eauto. intros. eapply context_pres_let_bodies_red in r. intros; eapply red_conv_conv_inv; eauto. eapply pres_let_bodies_trans; tea. - eapply pres_let_bodies_assumption_context; tea. now symmetry. + eapply pres_let_bodies_assumption_context; tea. now symmetry. Qed. Lemma trans_convSpec' {cf} {Σ : PCUICEnvironment.global_env_ext} {Γ Γ' T U} {wfΣ : PCUICTyping.wf Σ} : @@ -4463,7 +4463,7 @@ Lemma trans_convSpec' {cf} {Σ : PCUICEnvironment.global_env_ext} {Γ Γ' T U} { wt_conv_hetero Σ Γ Γ' T U -> #|Γ| = #|Γ'| -> assumption_context Γ -> - assumption_context Γ' -> + assumption_context Γ' -> convSpec (H:=cf' cf) (trans_global Σ) (trans_local Γ) (trans T) (trans U). Proof. intros wfΣ' cv len ass ass'. @@ -4510,21 +4510,21 @@ Proof. - elimtype False; depelim ass. Qed. -Lemma assumption_context_arities_context mdecl : +Lemma assumption_context_arities_context mdecl : assumption_context (arities_context mdecl). Proof. rewrite /arities_context rev_map_spec -map_rev. induction (List.rev mdecl); cbn; auto with pcuic. Qed. -Lemma expand_lets_smash_context_id Γ x : +Lemma expand_lets_smash_context_id Γ x : expand_lets (smash_context [] Γ) x = x. Proof. rewrite expand_lets_assumption_context //. pcuic. Qed. -Lemma expand_lets_expand_lets Γ Δ x : - expand_lets (Γ ,,, smash_context [] Δ) (expand_lets Δ x) = +Lemma expand_lets_expand_lets Γ Δ x : + expand_lets (Γ ,,, smash_context [] Δ) (expand_lets Δ x) = expand_lets (Γ ,,, Δ) x. Proof. rewrite expand_lets_app expand_lets_smash_context_id. @@ -4532,7 +4532,7 @@ Proof. now rewrite -expand_lets_app. Qed. -Lemma trans_type_local_ctx {cf} {Σ Γ Δ s} : +Lemma trans_type_local_ctx {cf} {Σ Γ Δ s} : wf Σ -> wf_trans Σ -> type_local_ctx (PCUICEnvTyping.lift_typing typing) Σ Γ Δ s -> type_local_ctx (PCUICEnvTyping.lift_typing (typing (H:=cf' cf))) (trans_global Σ) (trans_local Γ) (trans_local Δ) s. @@ -4542,14 +4542,14 @@ Proof. unfold PCUICLookup.wf_universe, wf_universe. destruct s => //. destruct a as [? [?|] ?] => /= //; intuition auto. - destruct a0 as [s' Hs]. exists s'. + destruct a0 as [s' Hs]. exists s'. all:rewrite -trans_local_app. now eapply (pcuic_expand_lets _ _ _ (tSort _)). now eapply (pcuic_expand_lets _ _ _ _). now eapply (pcuic_expand_lets _ _ _ (tSort _)). Qed. -Lemma trans_on_context {cf} {Σ Γ} : +Lemma trans_on_context {cf} {Σ Γ} : wf Σ -> wf_trans Σ -> on_context (PCUICEnvTyping.lift_typing typing) Σ Γ -> on_context (PCUICEnvTyping.lift_typing (typing (H:=cf' cf))) (trans_global Σ) (trans_local Γ). @@ -4561,7 +4561,7 @@ Proof. now eapply (pcuic_expand_lets _ _ _ _). Qed. -Lemma Alli_map {A B} (P : nat -> B -> Type) {f : A -> B} {n l} : +Lemma Alli_map {A B} (P : nat -> B -> Type) {f : A -> B} {n l} : Alli (fun n x => P n (f x)) n l -> Alli P n (map f l). Proof. @@ -4600,7 +4600,7 @@ Proof. now eapply typing_expand_lets. Qed. -Lemma on_free_vars_ctx_mon k k' Γ : +Lemma on_free_vars_ctx_mon k k' Γ : k <= k' -> on_free_vars_ctx (shiftnP k xpred0) Γ -> on_free_vars_ctx (shiftnP k' xpred0) Γ. @@ -4610,7 +4610,7 @@ Proof. repeat nat_compare_specs => //. Qed. -Lemma ctx_inst_wt {cf} {Σ Γ s Δ} : +Lemma ctx_inst_wt {cf} {Σ Γ s Δ} : ctx_inst Σ Γ s Δ -> All (wt Σ Γ) s. Proof. @@ -4630,9 +4630,9 @@ Proof. eapply typing_wf_local in t. now rewrite app_context_nil_l in t. Qed. -Lemma nth_error_smash_onfvs P Γ n c : +Lemma nth_error_smash_onfvs P Γ n c : nth_error (smash_context [] Γ) n = Some c -> - on_free_vars_ctx P (smash_context [] Γ) -> + on_free_vars_ctx P (smash_context [] Γ) -> on_free_vars_decl (shiftnP (context_assumptions Γ - S n) P) c. Proof. induction Γ in P, n, c |- * using ctx_length_rev_ind. @@ -4665,13 +4665,13 @@ Proof. } Qed. -Lemma on_free_vars_projs p ind n k : +Lemma on_free_vars_projs p ind n k : forallb (on_free_vars (shiftnP 1 p)) (projs ind n k). Proof. induction k; cbn; auto. Qed. -Lemma trans_on_udecl {cf} {Σ : global_env} {univs} : +Lemma trans_on_udecl {cf} {Σ : global_env} {univs} : on_udecl Σ univs -> on_udecl (trans_global_env Σ) univs. Proof. auto. Qed. @@ -4694,7 +4694,7 @@ Proof. * cbn. red. move: ond; rewrite /on_constant_decl. destruct c as [type [body|] univs] => /=. intros Hty; eapply (pcuic_expand_lets (Σ0, univs) [] _ _ X Hty IHX). - intros [s Hty]. exists s. + intros [s Hty]. exists s. exact (pcuic_expand_lets (Σ0, univs) [] _ _ X Hty IHX). * generalize ond. intros []; econstructor; eauto. + cbn. @@ -4704,7 +4704,7 @@ Proof. { cbn. destruct onArity as [s Hty]. exists s. exact (pcuic_expand_lets (Σ0, ind_universes m) [] _ _ X Hty IHX). } { instantiate (1 := ind_cunivs). - red in onConstructors. + red in onConstructors. eapply All2_map_left, All2_impl; tea. intros cdecl univs onc; generalize onc; intros []. have parsfvs: on_free_vars_ctx xpred0 (ind_params m). @@ -4753,7 +4753,7 @@ Proof. - cbn [trans_local map]. rewrite [smash_context _ (_ :: _)](smash_context_app_expand _ _ [_]). rewrite /snoc; cbn. unfold app_context. cbn. - rewrite expand_lets_ctx_tip /=. + rewrite expand_lets_ctx_tip /=. destruct univs => //. split. cbn in IHc. apply IHc, on_cargs. destruct on_cargs as [hs ht]. red in ht. @@ -4798,9 +4798,9 @@ Proof. destruct onArity as [s Hs]. rewrite -it_mkProd_or_LetIn_app in Hs. eapply type_it_mkProd_or_LetIn_inv in Hs as [? [? [Hs _]]]. - eapply PCUICClosedConv.sorts_local_ctx_All_local_env in Hs; eauto. + eapply PCUICClosedConv.sorts_local_ctx_All_local_env in Hs; eauto. now rewrite app_context_nil_l in Hs. } - { eapply wf_local_smash_end. + { eapply wf_local_smash_end. eapply sorts_local_ctx_wf_local in on_cargs => //. eapply weaken_wf_local => //. eapply wf_arities_context'; eauto. } @@ -4811,7 +4811,7 @@ Proof. rewrite shiftnP_add Nat.add_assoc //. rewrite trans_cstr_concl_eq //. rewrite -(trans_expand_lets (shiftnP (#|ind_params m| + #|ind_bodies m|) xpred0)) //. - rewrite shiftnP_add Nat.add_assoc //. + rewrite shiftnP_add Nat.add_assoc //. { rewrite cstr_eq in on_ctype. destruct on_ctype as [s Hs]. eapply subject_is_open_term in Hs. len in Hs. @@ -4851,13 +4851,13 @@ Proof. rewrite [ind_arities _]trans_arities_context -trans_local_app. rewrite -!trans_subst_instance_ctx. cbn in a. cbn. - eapply (trans_cumul_ctx_rel' (Σ := (Σ0, univs')) + eapply (trans_cumul_ctx_rel' (Σ := (Σ0, univs')) (Γ' := (arities_context (ind_bodies m),,, SE.smash_context [] (ind_params m))@[u'])) => //. { rewrite subst_instance_app subst_instance_smash. - rewrite subst_instance_expand_lets_ctx. + rewrite subst_instance_expand_lets_ctx. eapply wf_local_expand_lets. rewrite subst_instance_smash. unshelve eapply wf_local_smash_end. cbn; auto. - rewrite -!subst_instance_app_ctx. + rewrite -!subst_instance_app_ctx. pose proof (on_cargs onc). simpl in X. eapply sorts_local_ctx_wf_local in X0 => //. eapply typing_subst_instance_wf_local; tea. @@ -4867,7 +4867,7 @@ Proof. - eapply weaken_wf_local => //. now eapply wf_arities_context'. } { rewrite subst_instance_app subst_instance_smash. - rewrite subst_instance_expand_lets_ctx. + rewrite subst_instance_expand_lets_ctx. eapply wf_local_expand_lets. rewrite subst_instance_smash. unshelve eapply wf_local_smash_end. cbn; auto. rewrite -!subst_instance_app_ctx. @@ -4916,7 +4916,7 @@ Proof. rewrite -shiftnP_add. rewrite (on_free_vars_expand_lets_k _ _ 0) // shiftnP_add // /= shiftnP_add //. } rewrite -!trans_subst_instance. - eapply (trans_convSpec' (Σ := (Σ0, univs')) + eapply (trans_convSpec' (Σ := (Σ0, univs')) (Γ' := (arities_context (ind_bodies m),,, SE.smash_context [] (ind_params m,,, SE.smash_context [] (cstr_args cdecl)))@[u'])); eauto. @@ -4949,7 +4949,7 @@ Proof. { red in onParams. now eapply wf_local_closed_context in onParams. } intros indps. cbn in indps. forward onProjections. - intros eq. rewrite eq /= in indps. congruence. + intros eq. rewrite eq /= in indps. congruence. cbn. destruct (ind_ctors idecl) as [|c []] eqn:hctors => /= //. depelim onConstructors. depelim onConstructors. have wfargs : wf_local (Σ0, ind_universes m) (arities_context (ind_bodies m),,, ind_params m,,, cstr_args c). @@ -4994,12 +4994,12 @@ Proof. move/andP: hnth => [] _ o. red; rewrite -o shiftnP_add. lia_f_equal. } erewrite <-(trans_lift _ _); tea. - have fvslift : on_free_vars (shiftnP (n' + 1 + context_assumptions (ind_params m) + #|ind_bodies m|) xpred0) + have fvslift : on_free_vars (shiftnP (n' + 1 + context_assumptions (ind_params m) + #|ind_bodies m|) xpred0) (lift 1 n' (decl_type c0)). { rewrite -2!shiftnP_add Nat.add_comm. eapply on_free_vars_lift_impl. rewrite !shiftnP_add //. } - rewrite (trans_subst (shiftnP 1 (shiftnP (context_assumptions (ind_params m) + #|ind_bodies m|) xpred0)) xpred0). + rewrite (trans_subst (shiftnP 1 (shiftnP (context_assumptions (ind_params m) + #|ind_bodies m|) xpred0)) xpred0). { eapply on_free_vars_subst; [eapply on_free_vars_projs|]. rewrite projs_length !shiftnP_add Nat.add_assoc //. } { eapply (inds_is_open_terms [] ind). } @@ -5037,7 +5037,7 @@ Proof. have wf_ext : wf_global_ext Σ0 (ind_universes m). { destruct (ind_universes m) eqn:equniv => //. cbn. split => //. cbn. now eapply on_udecl_on_udecl_prop. } - eapply (trans_cumul_ctx_rel' (Σ := (Σ0, univs')) + eapply (trans_cumul_ctx_rel' (Σ := (Σ0, univs')) (Γ' := (smash_context [] (ind_params m))@[u'])) => //. { rewrite subst_instance_expand_lets_ctx. rewrite !subst_instance_smash. @@ -5063,11 +5063,11 @@ Qed. Lemma trans_wf_ext {cf} {Σ : global_env_ext} : wf_ext Σ -> wf_ext_trans Σ. Proof. - intros; split. now eapply trans_wf. destruct X. + intros; split. now eapply trans_wf. destruct X. now eapply trans_on_udecl. Qed. -(** From a typing derivation in pcuic we build one where there are no lets +(** From a typing derivation in pcuic we build one where there are no lets in constructor types, and branches of cases are appropriately substituted. *) Theorem expand_lets_sound {cf} {Σ : global_env_ext} {Γ t T} {wfΣ : wf Σ} : typing Σ Γ t T -> @@ -5094,7 +5094,7 @@ Proof. cbn. now rewrite -(on_free_vars_closedn 0) ona. Qed. -Lemma eval_wt {cf} {Σ} {wfΣ : wf Σ} {t t'} : +Lemma eval_wt {cf} {Σ} {wfΣ : wf Σ} {t t'} : wt Σ [] t -> eval Σ t t' -> wt Σ [] t'. @@ -5103,7 +5103,7 @@ Proof. now eapply subject_reduction_eval. Qed. -Lemma wt_closed {cf} {Σ} {wfΣ : wf Σ} {Γ t} : +Lemma wt_closed {cf} {Σ} {wfΣ : wf Σ} {Γ t} : wt Σ Γ t -> closedn #|Γ| t. Proof. @@ -5121,7 +5121,7 @@ Proof. eapply (substitution (Γ := []) (Δ := [])). now eapply subslet_ass_tip. rewrite app_context_nil_l. exact Hb. *) -Lemma closed_inst_case_context pars u ctx : +Lemma closed_inst_case_context pars u ctx : forallb (closedn 0) pars -> closedn_ctx #|pars| ctx -> closed_ctx (inst_case_context pars u ctx). @@ -5160,7 +5160,7 @@ Proof. now rewrite (isPrimApp_mkApps f1 [f2]). Qed. -Lemma trans_wcbveval {cf} {Σ} {wfΣ : wf Σ} t u : +Lemma trans_wcbveval {cf} {Σ} {wfΣ : wf Σ} t u : closed t -> eval Σ t u -> eval (trans_global_env Σ) (trans t) (trans u). Proof. @@ -5193,7 +5193,7 @@ Proof. * len. rewrite e0 /cstr_arity. cbn. rewrite context_assumptions_smash_context context_assumptions_map /= //. * now rewrite e1. - * cbn. + * cbn. rewrite trans_bcontext. rewrite !context_assumptions_smash_context !context_assumptions_map //. * rewrite /iota_red. @@ -5219,7 +5219,7 @@ Proof. { rewrite /iota_red. eapply closedn_subst0 => //. now rewrite forallb_rev; apply forallb_skipn. - cbn; len. rewrite skipn_length e0 /cstr_arity -e1 e2. + cbn; len. rewrite skipn_length e0 /cstr_arity -e1 e2. replace (ci_npar ci + context_assumptions (bcontext br) - ci_npar ci) with (context_assumptions (bcontext br)) by lia. eauto. @@ -5245,12 +5245,12 @@ Proof. rewrite /on_free_vars_terms forallb_rev. eapply forallb_impl; tea. intros. now eapply (@closedn_on_free_vars xpred0 0). rewrite map_rev. rewrite trans_bbody trans_subst_instance_ctx //. - + - cbn => cldiscr. specialize (IHev1 cldiscr). rewrite trans_mkApps in IHev1. eapply trans_declared_projection in d; tea. econstructor; tea. - { len. rewrite /cstr_arity e. cbn. + { len. rewrite /cstr_arity e. cbn. rewrite context_assumptions_smash_context /= /cstr_arity context_assumptions_map //. } rewrite nth_error_map e0 //. apply IHev2. @@ -5273,7 +5273,7 @@ Proof. rewrite -closed_unfold_fix_cunfold_eq; tea. now eapply closedn_trans in clfix. cbn in IHev3. rewrite trans_mkApps in IHev3. eapply IHev3. - + - move=> /= /andP[] clf cla. rewrite trans_mkApps /= in IHev1. eapply eval_closed in ev1; tea. @@ -5283,10 +5283,10 @@ Proof. rewrite trans_mkApps /=. eapply (trans_unfold_fix xpred0) in e; tea. 2:now eapply (@closedn_on_free_vars xpred0 0). - eapply eval_fix_value. eauto. eauto. + eapply eval_fix_value. eauto. eauto. rewrite -closed_unfold_fix_cunfold_eq; tea. now eapply closedn_trans in clfix. now len. - + - move=> /= /andP[] /andP[] clp. intros cldiscr clbrs. eapply eval_closed in cldiscr as clfix; eauto. @@ -5296,7 +5296,7 @@ Proof. rewrite -closed_unfold_cofix_cunfold_eq in e => //. forward IHev1. eauto. - forward IHev2. + forward IHev2. { cbn. rewrite clp clbrs closedn_mkApps /=. rewrite (closed_unfold_cofix mfix idx narg fn) // clargs //. } cbn in IHev2. rewrite trans_mkApps /= in IHev1. @@ -5306,7 +5306,7 @@ Proof. rewrite -closed_unfold_cofix_cunfold_eq; tea. now eapply closedn_trans in clfix. rewrite trans_mkApps in IHev2 => //. - + - move=> /=. intros cldiscr. eapply eval_closed in cldiscr as clfix; eauto. @@ -5314,7 +5314,7 @@ Proof. rewrite closedn_mkApps => /andP[] clfix clargs. rewrite -closed_unfold_cofix_cunfold_eq in e => //. forward IHev1. eauto. - forward IHev2. + forward IHev2. { cbn. rewrite closedn_mkApps /=. rewrite (closed_unfold_cofix mfix idx narg fn) // clargs //. } cbn in IHev2. rewrite trans_mkApps /= in IHev1. @@ -5324,7 +5324,7 @@ Proof. rewrite -closed_unfold_cofix_cunfold_eq; tea. now eapply closedn_trans in clfix. rewrite trans_mkApps in IHev2 => //. - + - move=> /= /andP[] clf cla. rewrite trans_mkApps map_app. eapply trans_declared_constructor in d; tea. @@ -5333,12 +5333,12 @@ Proof. + move: l; rewrite map_length /cstr_arity /= context_assumptions_smash_context context_assumptions_map //. + now eapply IHev2. - + - move=> /= /andP[] clf cla. eapply eval_app_cong; eauto. rewrite -isFixApp_trans -isConstructApp_trans -isPrimApp_trans. clear -i. induction f' => /= //. - + - move=> clt. eapply eval_atom. destruct t => //. Qed. @@ -5356,7 +5356,7 @@ Proof. destruct t => //. Qed. Set Printing Width 150. Lemma expanded_expand_lets {Σ : global_env} Γ t : - expanded Σ Γ t -> + expanded Σ Γ t -> expanded (trans_global_env Σ) Γ (PCUICExpandLets.trans t). Proof. induction 1 using expanded_ind; cbn. @@ -5369,11 +5369,11 @@ Proof. - do 2 eapply Forall_map. repeat toAll. eapply All_impl; tea. cbn. intros x [expb IH]. rewrite trans_bcontext trans_bbody. len; cbn. rewrite /id. - split. sq. + split. sq. { have: (assumption_context (smash_context [] (trans_local (bcontext x)))) by pcuic. clear. generalize (smash_context [] (trans_local (bcontext x))). induction c; intros; constructor. - apply IHc. now depelim H. + apply IHc. now depelim H. destruct a as [na [b|] ty]; cbn; constructor => //. now depelim H. } relativize (context_assumptions (bcontext x)). @@ -5401,16 +5401,16 @@ Proof. solve_all. Qed. -Lemma expanded_trans_local {Σ} Γ ctx : +Lemma expanded_trans_local {Σ} Γ ctx : expanded_context Σ Γ ctx -> expanded_context (trans_global_env Σ) Γ (trans_local ctx). Proof. rewrite /expanded_context. intros [a]; split. - eapply All_fold_map_context, All_fold_impl; tea; cbv beta; intros ??; cbn; intros []; + eapply All_fold_map_context, All_fold_impl; tea; cbv beta; intros ??; cbn; intros []; constructor; len; auto using expanded_expand_lets. Qed. -Lemma expanded_smash_context {Σ} Γ ctx : +Lemma expanded_smash_context {Σ} Γ ctx : expanded_context Σ Γ ctx -> expanded_context Σ Γ (smash_context [] ctx). Proof. rewrite /expanded_context. @@ -5422,7 +5422,7 @@ Proof. Qed. Lemma wf_cons_inv {cf} univs retro (Σ : global_declarations) d : - wf {| universes := univs; declarations := d :: Σ; retroknowledge := retro |} -> + wf {| universes := univs; declarations := d :: Σ; retroknowledge := retro |} -> wf {| universes := univs; declarations := Σ; retroknowledge := retro |}. Proof. intros []. split => //. now depelim o0. @@ -5431,8 +5431,8 @@ Qed. Lemma expanded_global_env_expand_lets {cf} Σ {wfΣ : wf Σ} : PCUICEtaExpand.expanded_global_env Σ -> expanded_global_env (trans_global_env Σ). -Proof. - destruct Σ as [[univs Σ] udecl]. cbn. unfold expanded_global_env; cbn. +Proof. + destruct Σ as [[univs Σ] udecl]. cbn. unfold expanded_global_env; cbn. intros etaenv; induction etaenv; cbn; constructor; auto. - forward IHetaenv by eapply wf_cons_inv; tea. auto. - forward IHetaenv by eapply wf_cons_inv; tea. @@ -5462,7 +5462,7 @@ Proof. destruct p as [[Σ udecl] t]; intros [etaenv etat]. destruct wtp as [wfΣ wtp]. cbn in *. split; cbn. - now eapply (expanded_global_env_expand_lets (cf:=cf) (Σ, udecl)). + now eapply (expanded_global_env_expand_lets (cf:=cf) (Σ, udecl)). cbn in *. now eapply expanded_expand_lets in etat. Qed. diff --git a/pcuic/theories/PCUICFirstorder.v b/pcuic/theories/PCUICFirstorder.v index dff1a0cb3..da3daedc3 100644 --- a/pcuic/theories/PCUICFirstorder.v +++ b/pcuic/theories/PCUICFirstorder.v @@ -3,7 +3,7 @@ From MetaCoq.Template Require Import config utils Kernames MCRelations. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrimitive - PCUICReduction + PCUICReduction PCUICReflect PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICCasesContexts PCUICWeakeningConv PCUICWeakeningTyp PCUICContextConversionTyp @@ -11,7 +11,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrimitive PCUICConfluence PCUICConversion PCUICUnivSubstitutionTyp PCUICCumulativity PCUICSR PCUICSafeLemmata - PCUICValidity PCUICPrincipality PCUICElimination + PCUICValidity PCUICPrincipality PCUICElimination PCUICOnFreeVars PCUICWellScopedCumulativity PCUICSN PCUICCanonicity. From MetaCoq Require Import PCUICArities PCUICSpine. @@ -21,73 +21,73 @@ Section firstorder. Context {Σ : global_env_ext}. Context {Σb : list (kername × bool)}. - + Fixpoint plookup_env {A} (Σ : list (kername × A)) (kn : kername) {struct Σ} : option A := match Σ with | [] => None | d :: tl => if eq_kername kn d.1 then Some d.2 else plookup_env tl kn - end. - (* + end. + (* Definition zo_type (t : term) := match (PCUICAstUtils.decompose_app t).1 with | tProd _ _ _ => false | tSort _ => false - | tInd (mkInd nm i) _ => match (plookup_env Σb nm) with + | tInd (mkInd nm i) _ => match (plookup_env Σb nm) with | Some l => nth i l false | None => false end | _ => true end. *) - + Definition firstorder_type (n k : nat) (t : term) := match (PCUICAstUtils.decompose_app t).1 with - | tInd (mkInd nm i) u => match (plookup_env Σb nm) with + | tInd (mkInd nm i) u => match (plookup_env Σb nm) with | Some b => b | None => false end | tRel i => (k <=? i) && (i false end. - (* + (* Definition firstorder_type (t : term) := match (PCUICAstUtils.decompose_app t).1 with - | tInd (mkInd nm i) _ => match (plookup_env Σb nm) with + | tInd (mkInd nm i) _ => match (plookup_env Σb nm) with | Some l => nth i l false | None => false end | _ => false end. *) - + Definition firstorder_con mind (c : constructor_body) := let inds := #|mind.(ind_bodies)| in - alli (fun k '({| decl_body := b ; decl_type := t ; decl_name := n|}) => + alli (fun k '({| decl_body := b ; decl_type := t ; decl_name := n|}) => firstorder_type inds k t) 0 (List.rev (c.(cstr_args) ++ mind.(ind_params)))%list. - + Definition firstorder_oneind mind (ind : one_inductive_body) := forallb (firstorder_con mind) ind.(ind_ctors) && negb (Universe.is_level (ind_sort ind)). - + Definition firstorder_mutind (mind : mutual_inductive_body) := (* if forallb (fun decl => firstorder_type decl.(decl_type)) mind.(ind_params) then *) (mind.(ind_finite) == Finite) && forallb (firstorder_oneind mind) mind.(ind_bodies) (* else repeat false (length mind.(ind_bodies)). *). - + Definition firstorder_ind (i : inductive) := match lookup_env Σ.1 (inductive_mind i) with | Some (InductiveDecl mind) => firstorder_mutind mind | _ => false end. - + End firstorder. - + Fixpoint firstorder_env' (Σ : global_declarations) := match Σ with | nil => [] - | (nm, ConstantDecl _) :: Σ' => - let Σb := firstorder_env' Σ' in + | (nm, ConstantDecl _) :: Σ' => + let Σb := firstorder_env' Σ' in ((nm, false) :: Σb) - | (nm, InductiveDecl mind) :: Σ' => - let Σb := firstorder_env' Σ' in + | (nm, InductiveDecl mind) :: Σ' => + let Σb := firstorder_env' Σ' in ((nm, @firstorder_mutind Σb mind) :: Σb) - end. + end. Definition firstorder_env (Σ : global_env_ext) := firstorder_env' Σ.1.(declarations). @@ -96,10 +96,10 @@ Section cf. Context {cf : config.checker_flags}. -Definition isPropositional Σ ind b := +Definition isPropositional Σ ind b := match lookup_env Σ (inductive_mind ind) with | Some (InductiveDecl mdecl) => - match nth_error mdecl.(ind_bodies) (inductive_ind ind) with + match nth_error mdecl.(ind_bodies) (inductive_ind ind) with | Some idecl => match destArity [] idecl.(ind_type) with | Some (_, s) => is_propositional s = b @@ -111,8 +111,8 @@ Definition isPropositional Σ ind b := end. Inductive firstorder_value Σ Γ : term -> Prop := -| firstorder_value_C i n ui u args pandi : - Σ ;;; Γ |- mkApps (tConstruct i n ui) args : +| firstorder_value_C i n ui u args pandi : + Σ ;;; Γ |- mkApps (tConstruct i n ui) args : mkApps (tInd i u) pandi -> Forall (firstorder_value Σ Γ) args -> isPropositional Σ i false -> @@ -174,10 +174,10 @@ Inductive firstorder_spine Σ (Γ : context) : term -> list term -> term -> Type Inductive instantiated {Σ} (Γ : context) : term -> Type := | instantiated_mkApps i u args : instantiated Γ (mkApps (tInd i u) args) -| instantiated_LetIn na d b ty : +| instantiated_LetIn na d b ty : instantiated Γ (ty {0 := d}) -> instantiated Γ (tLetIn na d b ty) -| instantiated_tProd na B i u args : +| instantiated_tProd na B i u args : @firstorder_ind Σ (@firstorder_env Σ) i -> (forall x, (* Σ ;;; Γ |- x : mkApps (tInd i u) args -> *) @@ -217,24 +217,24 @@ Proof using Type. now eapply isType_open. -- eapply cumul_Prod_inv in w as []. econstructor. ++ eapply type_ws_cumul_pb. 3: eapply PCUICContextConversion.ws_cumul_pb_eq_le; symmetry. all:eauto. - eapply isType_tProd in i0. eapply i0. + eapply isType_tProd in i0. eapply i0. ++ rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn. autorewrite with subst. cbn. eapply X. len. lia. eapply typing_spine_strengthen. eauto. 2:{ replace (it_mkProd_or_LetIn (subst_context [hd] 0 Γ0) (mkApps (tInd i u) (map (subst [hd] (#|Γ0| + 0)) pars))) with ((PCUICAst.subst10 hd (it_mkProd_or_LetIn Γ0 (mkApps (tInd i u) pars)))). - 2:{ rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn. now autorewrite with subst. } + 2:{ rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn. now autorewrite with subst. } eapply substitution0_ws_cumul_pb. eauto. eauto. } replace (it_mkProd_or_LetIn (subst_context [hd] 0 Γ0) (mkApps (tInd i u) (map (subst [hd] (#|Γ0| + 0)) pars))) with ((PCUICAst.subst10 hd (it_mkProd_or_LetIn Γ0 (mkApps (tInd i u) pars)))). - 2:{ rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn. now autorewrite with subst. } + 2:{ rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn. now autorewrite with subst. } eapply isType_subst. eapply PCUICSubstitution.subslet_ass_tip. eauto. eapply isType_tProd in i0 as [_ tprod]. eapply isType_context_conversion; tea. constructor. eapply ws_cumul_ctx_pb_refl. now eapply typing_wf_local, PCUICClosedTyp.wf_local_closed_context in t. constructor; tea. constructor. pcuic. eapply validity in t. now eauto. Qed. - + Lemma leb_spect : forall x y : nat, BoolSpecSet (x <= y) (y < x) (x <=? y). Proof using Type. intros x y. destruct (x <=? y) eqn:E; @@ -251,10 +251,10 @@ Proof using Type. eapply IHn0. lia. Qed. -Lemma alli_subst_instance (Γ : context) u p : +Lemma alli_subst_instance (Γ : context) u p : (forall k t, p k t = p k t@[u]) -> - forall n, - alli (fun (k : nat) '{| decl_type := t |} => p k t) n Γ = + forall n, + alli (fun (k : nat) '{| decl_type := t |} => p k t) n Γ = alli (fun (k : nat) '{| decl_type := t |} => p k t) n Γ@[u]. Proof using Type. intros hp. @@ -264,11 +264,11 @@ Qed. Arguments firstorder_mutind : clear implicits. -Lemma plookup_env_lookup_env {Σ : global_env_ext} kn b : +Lemma plookup_env_lookup_env {Σ : global_env_ext} kn b : plookup_env (firstorder_env Σ) kn = Some b -> ∑ Σ' decl, lookup_env Σ kn = Some decl × extends_decls Σ' Σ × - match decl with + match decl with | ConstantDecl _ => b = false | InductiveDecl mind => b = firstorder_mutind (firstorder_env' (declarations Σ')) mind @@ -316,7 +316,7 @@ Proof using Type. all:tea. Qed. -Lemma instantiated_typing_spine_firstorder_spine {Σ : global_env_ext} {wfΣ : wf Σ} Γ T args T' : +Lemma instantiated_typing_spine_firstorder_spine {Σ : global_env_ext} {wfΣ : wf Σ} Γ T args T' : instantiated (Σ := Σ) Γ T -> arity_spine Σ Γ T args T' -> isType Σ Γ T -> @@ -386,14 +386,14 @@ Lemma plookup_env_extends {Σ Σ' : global_env} kn b : plookup_env (firstorder_env' (declarations Σ)) kn = Some b. Proof. intros [equ [Σ'' eq] eqr]. rewrite eq. - clear equ eqr. intros []. clear o. + clear equ eqr. intros []. clear o. rewrite eq in o0. clear eq. move: o0. generalize (declarations Σ'). clear Σ'. induction Σ''. - cbn => //. - cbn. destruct a => //. intros gs ong. depelim ong. specialize (IHΣ'' _ ong). - destruct o as [f ? ? ?]. + destruct o as [f ? ? ?]. destruct g => //. * intros hl. specialize (IHΣ'' hl). eapply plookup_env_Some_not_fresh in hl. @@ -409,7 +409,7 @@ Proof. + now intros neq. Qed. -Lemma firstorder_mutind_ext {Σ Σ' : global_env_ext} m : +Lemma firstorder_mutind_ext {Σ Σ' : global_env_ext} m : extends_decls Σ' Σ -> wf Σ -> firstorder_mutind (firstorder_env' (declarations Σ')) m -> @@ -444,14 +444,14 @@ Proof using Type. (* revert Hspine. *) unfold type_of_constructor. erewrite cstr_eq. 2: eapply p. rewrite <- it_mkProd_or_LetIn_app. - rewrite PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn. + rewrite PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn. rewrite PCUICSpine.subst0_it_mkProd_or_LetIn. intros Hspine. match goal with | [ |- firstorder_spine _ _ ?T _ _ ] => assert (@instantiated Σ [] T) as Hi end. { clear Hspine. destruct Hdecl as [[d1 d3] d2]. pose proof d3 as Hdecl. - unfold firstorder_ind in Hind. + unfold firstorder_ind in Hind. rewrite d1 in Hind. solve_all. clear a. move/andP: Hind => [indf H0]. eapply forallb_nth_error in H0 as H'. @@ -461,7 +461,7 @@ Proof using Type. eapply nth_error_forallb in H. 2: eauto. unfold firstorder_con in H. revert H. cbn. - unfold cstr_concl. + unfold cstr_concl. rewrite PCUICUnivSubst.subst_instance_mkApps subst_mkApps. rewrite subst_instance_length app_length. unfold cstr_concl_head. rewrite PCUICInductives.subst_inds_concl_head. now eapply nth_error_Some_length in Hdecl. @@ -469,13 +469,13 @@ Proof using Type. generalize (cstr_args cbody ++ ind_params mind)%list. clear -wfΣ d1 indf H1 H0 Hdecl. (* generalize conclusion to mkApps tInd args *) - intros c. + intros c. change (list context_decl) with context in c. move: (map (subst (inds _ _ _) _) _). intros args. rewrite (alli_subst_instance _ ui (fun k t => firstorder_type _ #|ind_bodies mind| k t)). { intros k t. - rewrite /firstorder_type. + rewrite /firstorder_type. rewrite -PCUICUnivSubstitutionConv.subst_instance_decompose_app /=. destruct (decompose_app) => //=. destruct t0 => //. } replace (List.rev c)@[ui] with (List.rev c@[ui]). @@ -486,7 +486,7 @@ Proof using Type. autorewrite with substu subst. rewrite subst_context_nil. cbn -[subst0]. econstructor. - - rewrite rev_app_distr /=. destruct d as [na [b|] t]. + - rewrite rev_app_distr /=. destruct d as [na [b|] t]. + move=> /andP[] fot foΓ. rewrite subst_context_app /=. rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=. @@ -498,7 +498,7 @@ Proof using Type. revert foΓ. move: (lift0 #|ind_bodies mind| _). generalize 0. induction (List.rev Γ) => //. - cbn -[subst_telescope]. intros n t. + cbn -[subst_telescope]. intros n t. destruct a; cbn -[subst_telescope]. move/andP => [] fo fol. rewrite PCUICContextSubst.subst_telescope_cons /=. @@ -538,7 +538,7 @@ Proof using Type. revert foΓ. generalize (lift0 #|ind_bodies mind| x). generalize 0. induction (List.rev Γ) => //. - cbn -[subst_telescope]. intros n t. + cbn -[subst_telescope]. intros n t. destruct a; cbn -[subst_telescope]. move/andP => [] fo fol. rewrite PCUICContextSubst.subst_telescope_cons /=. @@ -573,7 +573,7 @@ Proof using Type. revert foΓ. generalize (lift0 #|ind_bodies mind| x). generalize 0. induction (List.rev Γ) => //. - cbn -[subst_telescope]. intros n t. + cbn -[subst_telescope]. intros n t. destruct a; cbn -[subst_telescope]. move/andP => [] fo fol. rewrite PCUICContextSubst.subst_telescope_cons /=. @@ -601,7 +601,7 @@ Proof using Type. autorewrite with substu subst. rewrite subst_instance_length app_length. rewrite PCUICInductives.subst_inds_concl_head. { cbn. destruct Hdecl as [[d1 d2] d3]. eapply nth_error_Some. rewrite d2. congruence. } - match goal with [ |- context[mkApps _ ?args]] => generalize args end. + match goal with [ |- context[mkApps _ ?args]] => generalize args end. intros args' Hi Spine. eapply instantiated_typing_spine_firstorder_spine; tea. now eapply typing_spine_arity_spine in Spine. @@ -614,7 +614,7 @@ Proof using Type. induction Δ using PCUICInduction.ctx_length_rev_ind; cbn. - eapply invert_cumul_sort_ind. - rewrite it_mkProd_or_LetIn_app; destruct d as [na [b|] ty]; cbn. - * intros hl. + * intros hl. eapply ws_cumul_pb_LetIn_l_inv in hl. rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn in hl. eapply H, hl. now len. @@ -623,16 +623,16 @@ Qed. Lemma firstorder_value_spec Σ t i u args mind : wf_ext Σ -> wf_local Σ [] -> - Σ ;;; [] |- t : mkApps (tInd i u) args -> - PCUICWcbvEval.value Σ t -> + Σ ;;; [] |- t : mkApps (tInd i u) args -> + PCUICWcbvEval.value Σ t -> lookup_env Σ (i.(inductive_mind)) = Some (InductiveDecl mind) -> @firstorder_ind Σ (firstorder_env Σ) i -> firstorder_value Σ [] t. Proof using Type. intros Hwf Hwfl Hty Hvalue. - revert mind i u args Hty. - - induction Hvalue as [ t Hvalue | t args' Hhead Hargs IH ] using PCUICWcbvEval.value_values_ind; + revert mind i u args Hty. + + induction Hvalue as [ t Hvalue | t args' Hhead Hargs IH ] using PCUICWcbvEval.value_values_ind; intros mind i u args Hty Hlookup Hfo. - destruct t; inversion_clear Hvalue. + exfalso. eapply inversion_Sort in Hty as (? & ? & Hcumul); eauto. @@ -650,7 +650,7 @@ Proof using Type. eapply ws_cumul_pb_LetIn_l_inv in w. rewrite /subst1 PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn PCUICLiftSubst.subst_it_mkProd_or_LetIn in w. now eapply invert_cumul_it_mkProd_or_LetIn_Sort_Ind in w. - * rewrite it_mkProd_or_LetIn_app in w. cbn in w. + * rewrite it_mkProd_or_LetIn_app in w. cbn in w. now eapply invert_cumul_prod_ind in w. + eapply inversion_Construct in Hty as Hty'; eauto. destruct Hty' as (? & ? & ? & ? & ? & ? & ?). @@ -658,7 +658,7 @@ Proof using Type. eapply PCUICInductiveInversion.Construct_Ind_ind_eq with (args := []); eauto. } eapply firstorder_value_C with (args := []); eauto. - eapply firstorder_ind_propositional; eauto. sq. eauto. + eapply firstorder_ind_propositional; eauto. sq. eauto. now eapply (declared_constructor_inductive (ind := (i, _))). + exfalso. eapply invert_fix_ind with (args := []) in Hty as []. destruct unfold_fix as [ [] | ]; auto. eapply nth_error_nil. @@ -680,10 +680,10 @@ Proof using Type. destruct Hty' as (([[[]]] & ?) & ? & ? & ? & ? & _). subst. econstructor; eauto. 2:{ eapply firstorder_ind_propositional; sq; eauto. eapply declared_constructor_inductive in d. eauto. } - eapply PCUICSpine.typing_spine_strengthen in spine. 3: eauto. + eapply PCUICSpine.typing_spine_strengthen in spine. 3: eauto. 2: eapply PCUICInductiveInversion.declared_constructor_valid_ty; eauto. - eapply firstorder_args in spine; eauto. + eapply firstorder_args in spine; eauto. clear c0 c1 e0 w Hty H0 Hargs. induction spine. * econstructor. diff --git a/pcuic/theories/PCUICGlobalEnv.v b/pcuic/theories/PCUICGlobalEnv.v index 99f935d00..724f59be2 100644 --- a/pcuic/theories/PCUICGlobalEnv.v +++ b/pcuic/theories/PCUICGlobalEnv.v @@ -4,7 +4,7 @@ From MetaCoq.Template Require Import config utils uGraph. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICReflect PCUICTyping. -(** Injectivity of declared_*, inversion lemmas on declared global references and +(** Injectivity of declared_*, inversion lemmas on declared global references and universe consistency of the global environment. *) @@ -29,7 +29,7 @@ Lemma declared_constructor_inj {Σ mdecl mdecl' idecl idecl' cdecl cdecl' c} : declared_constructor Σ c mdecl idecl cdecl' -> mdecl = mdecl' /\ idecl = idecl' /\ cdecl = cdecl'. Proof. - intros [] []. + intros [] []. destruct (declared_inductive_inj H H1); subst. rewrite H0 in H2. intuition congruence. Qed. @@ -39,7 +39,7 @@ Lemma declared_projection_inj {Σ mdecl mdecl' idecl idecl' cdecl cdecl' pdecl p declared_projection Σ p mdecl' idecl' cdecl' pdecl' -> mdecl = mdecl' /\ idecl = idecl' /\ cdecl = cdecl' /\ pdecl = pdecl'. Proof. - intros [] []. + intros [] []. destruct (declared_constructor_inj H H1) as [? []]; subst. destruct H0, H2. rewrite H0 in H2. intuition congruence. @@ -96,7 +96,7 @@ Proof. now specialize (decls _ Hctr). Qed. -Lemma LevelSet_in_union_global Σ l ls : +Lemma LevelSet_in_union_global Σ l ls : LevelSet.In l (LevelSet.union ls (universes Σ).1) -> LevelSet.In l (LevelSet.union ls (global_levels (universes Σ))). Proof. @@ -131,7 +131,7 @@ Qed. Definition global_ext_uctx_consistent {cf:checker_flags} {P} Σ : on_global_env_ext cumulSpec0 P Σ -> consistent (global_ext_uctx Σ).2. -Proof. +Proof. intros HΣ. cbn. unfold global_ext_constraints. unfold wf_ext, on_global_env_ext in HΣ. destruct HΣ as (_ & _ & _ & HH & _). apply HH. diff --git a/pcuic/theories/PCUICGuardCondition.v b/pcuic/theories/PCUICGuardCondition.v index 3cfc402fd..5a27df7c6 100644 --- a/pcuic/theories/PCUICGuardCondition.v +++ b/pcuic/theories/PCUICGuardCondition.v @@ -6,21 +6,21 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils (* AXIOM postulate correctness of the guard condition checker *) -Class GuardCheckerCorrect := +Class GuardCheckerCorrect := { guard_red1 b Σ Γ mfix mfix' idx : guard b Σ Γ mfix -> - red1 Σ Γ ((if b then tFix else tCoFix) mfix idx) + red1 Σ Γ ((if b then tFix else tCoFix) mfix idx) ((if b then tFix else tCoFix) mfix' idx) -> guard b Σ Γ mfix' ; guard_eq_term b Σ Γ mfix mfix' idx : guard b Σ Γ mfix -> - upto_names ((if b then tFix else tCoFix) mfix idx) + upto_names ((if b then tFix else tCoFix) mfix idx) ((if b then tFix else tCoFix) mfix' idx) -> guard b Σ Γ mfix' ; - guard_extends b Σ Γ mfix Σ' : + guard_extends b Σ Γ mfix Σ' : extends Σ.1 Σ'.1 -> guard b Σ Γ mfix -> guard b Σ' Γ mfix ; @@ -33,7 +33,7 @@ Class GuardCheckerCorrect := guard_nl b Σ Γ mfix : let mfix' := map (map_def_anon nl nl) mfix in guard b Σ Γ mfix -> guard b (nlg Σ) (nlctx Γ) mfix' ; - + guard_subst_instance {cf:checker_flags} b Σ Γ mfix u univs : let mfix' := map (map_def (subst_instance u) (subst_instance u)) mfix in consistent_instance_ext (Σ.1, univs) Σ.2 u -> @@ -51,7 +51,7 @@ Class GuardCheckerCorrect := urenaming P Γ Δ f -> guard b Σ Δ mfix -> guard b Σ Γ mfix' ; - + }. Axiom guard_checking_correct : GuardCheckerCorrect. diff --git a/pcuic/theories/PCUICInductiveInversion.v b/pcuic/theories/PCUICInductiveInversion.v index 4716b5b1d..e41afe870 100644 --- a/pcuic/theories/PCUICInductiveInversion.v +++ b/pcuic/theories/PCUICInductiveInversion.v @@ -3,20 +3,20 @@ From Coq Require Import Utf8. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICInduction PCUICLiftSubst PCUICUnivSubst - PCUICTyping PCUICGlobalEnv + PCUICTyping PCUICGlobalEnv PCUICWeakeningEnv PCUICWeakeningEnvTyp PCUICWeakeningConv PCUICWeakeningTyp PCUICSigmaCalculus (* for smash_context lemmas, to move *) PCUICSubstitution PCUICClosed PCUICClosedConv PCUICClosedTyp PCUICCumulativity PCUICGeneration PCUICReduction PCUICEquality PCUICConfluence PCUICCasesContexts - PCUICOnFreeVars PCUICContextConversion PCUICContextConversionTyp PCUICContextSubst + PCUICOnFreeVars PCUICContextConversion PCUICContextConversionTyp PCUICContextSubst PCUICUnivSubstitutionConv PCUICUnivSubstitutionTyp PCUICConversion PCUICInversion PCUICContexts PCUICArities PCUICSpine PCUICInductives PCUICWellScopedCumulativity PCUICValidity. Require Import Equations.Type.Relation_Properties. -Require Import Equations.Prop.DepElim. +Require Import Equations.Prop.DepElim. From Equations Require Import Equations. Derive Subterm for term. Require Import ssreflect. @@ -163,7 +163,7 @@ Lemma type_tCoFix_inv {cf:checker_flags} (Σ : global_env_ext) Γ mfix idx T : w (Σ ;;; Γ ⊢ dtype d ≤ T). Proof. intros wfΣ H. depind H. - - exists decl. + - exists decl. specialize (nth_error_all e a1) as Hty. destruct decl as [name ty body rarg]; simpl in *. intuition auto. @@ -172,7 +172,7 @@ Proof. rewrite subst_context_nil /= in Hty. eapply refine_type; eauto. rewrite simpl_subst_k //. len. - apply subslet_cofix; auto. + apply subslet_cofix; auto. * eapply nth_error_all in a0; tea. cbn in a0. now eapply isType_ws_cumul_pb_refl. - destruct (IHtyping1 wfΣ) as [d [[[Hnth wfcofix] ?] ?]]. exists d. intuition auto. @@ -248,7 +248,7 @@ Section OnConstructor. Context {cf:checker_flags} {Σ : global_env} {ind mdecl idecl cdecl} {wfΣ: wf Σ} (declc : declared_constructor Σ ind mdecl idecl cdecl). - Lemma on_constructor_wf_args : + Lemma on_constructor_wf_args : wf_local (Σ, ind_universes mdecl) (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, cstr_args cdecl). Proof using declc wfΣ. @@ -270,14 +270,14 @@ Section OnConstructor. cstr_args cdecl) ((to_extended_list_k (ind_params mdecl) #|cstr_args cdecl|) ++ (cstr_indices cdecl)) inst - (ind_params mdecl ,,, ind_indices idecl). + (ind_params mdecl ,,, ind_indices idecl). Proof using declc wfΣ. pose proof (on_declared_constructor declc) as [[onmind oib] [cunivs [hnth onc]]]. pose proof (onc.(on_cargs)). simpl in X. split. split. split. 2:{ eapply (weaken_lookup_on_global_env' _ _ (InductiveDecl mdecl)); tea. eapply declc. } - red. apply wfΣ. + red. apply wfΣ. eapply sorts_local_ctx_wf_local in X => //. clear X. eapply weaken_wf_local => //. eapply wf_arities_context; eauto; eapply declc. @@ -302,11 +302,11 @@ Section OnConstructor. rewrite Hdecl in cum'; clear Hdecl. assert(closed (ind_type idecl)). { pose proof (oib.(onArity)). rewrite (oib.(ind_arity_eq)) in X0 |- *. - destruct X0 as [s Hs]. now apply subject_closed in Hs. } + destruct X0 as [s Hs]. now apply subject_closed in Hs. } rewrite lift_closed in cum' => //. eapply typing_spine_strengthen in sp; simpl. 3:tea. - move: sp. + move: sp. rewrite (oib.(ind_arity_eq)). rewrite -it_mkProd_or_LetIn_app. move=> sp. simpl in sp. @@ -323,7 +323,7 @@ Section OnConstructorExt. Context {cf} {Σ} {wfΣ : wf Σ} {ind mdecl idecl cdecl} (declc : declared_constructor Σ ind mdecl idecl cdecl). - Lemma on_constructor_inst_wf_args u : + Lemma on_constructor_inst_wf_args u : consistent_instance_ext Σ (ind_universes mdecl) u -> wf_local Σ ((ind_params mdecl)@[u] ,,, subst_context (ind_subst mdecl (fst ind) u) #|ind_params mdecl| (cstr_args cdecl)@[u]). Proof using declc wfΣ. @@ -343,7 +343,7 @@ Section OnConstructorExt. now len in X. Qed. - Lemma on_constructor_inst u : + Lemma on_constructor_inst u : consistent_instance_ext Σ (ind_universes mdecl) u -> wf_local Σ (subst_instance u (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, cstr_args cdecl)) * @@ -356,7 +356,7 @@ Section OnConstructorExt. (to_extended_list_k (ind_params mdecl) #|cstr_args cdecl|) ++ map (subst_instance u) (cstr_indices cdecl)) inst (subst_instance u (ind_params mdecl) ,,, - subst_instance u (ind_indices idecl)). + subst_instance u (ind_indices idecl)). Proof using declc wfΣ. intros cu. destruct (on_constructor_subst declc) as [[wfext wfl] [inst sp]]. @@ -367,8 +367,8 @@ Section OnConstructorExt. Qed. End OnConstructorExt. -Lemma on_constructor_inst_pars_indices {cf:checker_flags} {Σ ind u mdecl idecl cdecl Γ pars parsubst} : - wf Σ.1 -> +Lemma on_constructor_inst_pars_indices {cf:checker_flags} {Σ ind u mdecl idecl cdecl Γ pars parsubst} : + wf Σ.1 -> declared_constructor Σ.1 ind mdecl idecl cdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> spine_subst Σ Γ pars parsubst (subst_instance u (ind_params mdecl)) -> @@ -384,7 +384,7 @@ Lemma on_constructor_inst_pars_indices {cf:checker_flags} {Σ ind u mdecl idecl (map (subst_instance u) (cstr_indices cdecl)))) inst (lift_context #|cstr_args cdecl| 0 - (subst_context parsubst 0 (subst_instance u (ind_indices idecl)))). + (subst_context parsubst 0 (subst_instance u (ind_indices idecl)))). Proof. move=> wfΣ declc cext sp. (* destruct (on_declared_constructor declc) as []. .declm oi oib onc *) @@ -408,7 +408,7 @@ Proof. rewrite closedn_ctx_app in X; simpl; eauto; move/andb_and: X; intuition auto; now rewrite closedn_subst_instance_context. } - assert (closedn_ctx (#|ind_params mdecl| + #|cstr_args cdecl|) (subst_instance u (ind_indices idecl))) + assert (closedn_ctx (#|ind_params mdecl| + #|cstr_args cdecl|) (subst_instance u (ind_indices idecl))) as clinds'. { eapply closedn_ctx_upwards; eauto. lia. } rewrite closed_ctx_subst // in spr. @@ -441,7 +441,7 @@ Proof. (fun x : term => subst (List.rev pars) #|cstr_args cdecl| (lift0 #|cstr_args cdecl| x)) - (extended_subst (subst_instance u (ind_params mdecl)) 0) = + (extended_subst (subst_instance u (ind_params mdecl)) 0) = (map (fun x : term => (lift0 #|cstr_args cdecl| @@ -456,19 +456,19 @@ Proof. rewrite subst_map_lift_lift_context in spr. rewrite -(context_subst_length sp). len. - rewrite closed_ctx_subst //. + rewrite closed_ctx_subst //. rewrite (closed_ctx_subst (List.rev pars)) // in spr. eexists. eauto. Qed. Lemma mkApps_ind_typing_spine {cf:checker_flags} Σ Γ Γ' ind i - inst ind' i' args args' : + inst ind' i' args args' : wf Σ.1 -> wf_local Σ Γ -> isType Σ Γ (it_mkProd_or_LetIn Γ' (mkApps (tInd ind i) args)) -> - typing_spine Σ Γ (it_mkProd_or_LetIn Γ' (mkApps (tInd ind i) args)) inst + typing_spine Σ Γ (it_mkProd_or_LetIn Γ' (mkApps (tInd ind i) args)) inst (mkApps (tInd ind' i') args') -> - ∑ instsubst, + ∑ instsubst, [× make_context_subst (List.rev Γ') inst [] = Some instsubst, #|inst| = context_assumptions Γ', ind = ind', R_ind_universes Σ ind #|args| i i', All2 (fun par par' => Σ ;;; Γ ⊢ par = par') (map (subst0 instsubst) args) args' & @@ -480,12 +480,12 @@ Proof. depelim Hsp. eapply ws_cumul_pb_Ind_l_inv in w as [i'' [args'' [? ?]]]; auto. eapply invert_red_mkApps_tInd in c as [? [eq ?]]; auto. solve_discr. - exists nil. + exists nil. split; pcuic. clear i0. relativize (map (subst0 []) args). 2:rewrite subst_empty_eq map_id //. clear i1. revert args' a0. clear -wfΣ wfΓ a. - induction a; intros args' H; depelim H; constructor. + induction a; intros args' H; depelim H; constructor. transitivity y; auto. symmetry. now eapply red_conv. now eauto. now eapply invert_cumul_ind_prod in w. @@ -525,7 +525,7 @@ Proof. now rewrite List.rev_involutive subst_context_length in Hisub. } rewrite H. now rewrite -(subst_app_simpl isub [b] 0). } - exact Hargs. + exact Hargs. eapply subslet_app; eauto. rewrite -{1}(subst_empty 0 b). repeat constructor. rewrite !subst_empty. rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /= in wat. @@ -547,7 +547,7 @@ Proof. eapply (isType_subst (Δ := [_]) [hd]) in wat. now rewrite subst_it_mkProd_or_LetIn Nat.add_0_r subst_mkApps in wat. eapply subslet_ass_tip. eapply type_ws_cumul_pb; tea. now symmetry. } - rewrite subst_mkApps Nat.add_0_r in cumulB. simpl in *. + rewrite subst_mkApps Nat.add_0_r in cumulB. simpl in *. rewrite context_assumptions_subst in IH. eapply typing_spine_strengthen in Hsp. 3:eapply cumulB. all:eauto. @@ -578,7 +578,7 @@ Proof. * pcuic. Qed. -Lemma wf_cofixpoint_typing_spine {cf:checker_flags} (Σ : global_env_ext) Γ ind u mfix idx d args args' : +Lemma wf_cofixpoint_typing_spine {cf:checker_flags} (Σ : global_env_ext) Γ ind u mfix idx d args args' : wf Σ.1 -> wf_local Σ Γ -> wf_cofixpoint Σ mfix -> nth_error mfix idx = Some d -> @@ -602,11 +602,11 @@ Lemma Construct_Ind_ind_eq {cf:checker_flags} {Σ} (wfΣ : wf Σ.1): forall {Γ n i args u i' args' u' mdecl idecl cdecl}, Σ ;;; Γ |- mkApps (tConstruct i n u) args : mkApps (tInd i' u') args' -> declared_constructor Σ.1 (i, n) mdecl idecl cdecl -> - (i = i') * + (i = i') * (* Universe instances match *) R_ind_universes Σ i (context_assumptions (ind_params mdecl) + #|cstr_indices cdecl|) u u' * - consistent_instance_ext Σ (ind_universes mdecl) u * - consistent_instance_ext Σ (ind_universes mdecl) u' * + consistent_instance_ext Σ (ind_universes mdecl) u * + consistent_instance_ext Σ (ind_universes mdecl) u' * (#|args| = (ind_npars mdecl + context_assumptions cdecl.(cstr_args))%nat) * ∑ parsubst argsubst parsubst' argsubst', let parctx := (subst_instance u (ind_params mdecl)) in @@ -618,21 +618,21 @@ Lemma Construct_Ind_ind_eq {cf:checker_flags} {Σ} (wfΣ : wf Σ.1): ((subst_context (inds (inductive_mind i) u' mdecl.(ind_bodies)) #|ind_params mdecl| (subst_instance u' cdecl.(cstr_args))))) in let argctx' := (subst_context parsubst' 0 (subst_instance u' idecl.(ind_indices))) in - + [× spine_subst Σ Γ (firstn (ind_npars mdecl) args) parsubst parctx, spine_subst Σ Γ (firstn (ind_npars mdecl) args') parsubst' parctx', spine_subst Σ Γ (skipn (ind_npars mdecl) args) argsubst argctx, spine_subst Σ Γ (skipn (ind_npars mdecl) args') argsubst' argctx' & - ∑ s, + ∑ s, sorts_local_ctx (lift_typing typing) Σ Γ argctx2 s × (** Parameters match *) ws_cumul_pb_terms Σ Γ (firstn mdecl.(ind_npars) args) (firstn mdecl.(ind_npars) args') × (** Indices match *) ws_cumul_pb_terms Σ Γ - (map (subst0 (argsubst ++ parsubst) ∘ + (map (subst0 (argsubst ++ parsubst) ∘ subst (inds (inductive_mind i) u mdecl.(ind_bodies)) (#|cdecl.(cstr_args)| + #|ind_params mdecl|) - ∘ (subst_instance u)) + ∘ (subst_instance u)) cdecl.(cstr_indices)) (skipn mdecl.(ind_npars) args') ]. Proof. @@ -643,16 +643,16 @@ Proof. destruct h as [T [hC hs]]. apply inversion_Construct in hC as [mdecl' [idecl' [cdecl' [hΓ [isdecl [const htc]]]]]]; auto. - assert (vty:=declared_constructor_valid_ty _ _ _ _ _ _ _ _ wfΣ hΓ isdecl const). + assert (vty:=declared_constructor_valid_ty _ _ _ _ _ _ _ _ wfΣ hΓ isdecl const). eapply typing_spine_strengthen in hs. 3:eapply htc. all:eauto. destruct (declared_constructor_inj isdecl declc) as [? [? ?]]. subst mdecl' idecl' cdecl'. clear isdecl. pose proof (on_constructor_inst declc _ const). destruct declc as [decli declc]. destruct onc as [argslength cdecl_eq [cs' t] cargs cinds]; simpl. - simpl in *. + simpl in *. unfold type_of_constructor in hs. simpl in hs. - rewrite cdecl_eq in hs. + rewrite cdecl_eq in hs. rewrite !subst_instance_it_mkProd_or_LetIn in hs. rewrite !subst_it_mkProd_or_LetIn subst_instance_length Nat.add_0_r in hs. rewrite subst_instance_mkApps subst_mkApps subst_instance_length in hs. @@ -710,7 +710,7 @@ Proof. now eapply subslet_inds; eauto. rewrite -app_context_assoc. eapply weaken_wf_local => //. - rewrite -subst_instance_app_ctx. + rewrite -subst_instance_app_ctx. apply a. - exists (map (subst_instance_univ u') x). split. * move/onParams: onmind. rewrite /on_context. @@ -719,7 +719,7 @@ Proof. 2:destruct decli; eauto. clear -wfar wfpars wfΣ hΓ cons decli t cargs sargs H0 H' a spars a0. eapply (subst_sorts_local_ctx (Γ' := []) - (Δ := subst_context (inds (inductive_mind i) u' (ind_bodies mdecl)) 0 + (Δ := subst_context (inds (inductive_mind i) u' (ind_bodies mdecl)) 0 (subst_instance u' (ind_params mdecl)))) => //. simpl. eapply weaken_wf_local => //. rewrite closed_ctx_subst => //. @@ -754,12 +754,12 @@ Proof. (map_map_compose _ _ _ (subst_instance u) (fun x => subst _ _ (subst _ _ x))). rewrite subst_instance_to_extended_list_k. - rewrite -[map _ (to_extended_list_k _ _)]map_map_compose. + rewrite -[map _ (to_extended_list_k _ _)]map_map_compose. rewrite -to_extended_list_k_map_subst. rewrite subst_instance_length. lia. rewrite map_subst_app_to_extended_list_k. rewrite firstn_length_le => //. - + erewrite subst_to_extended_list_k. rewrite map_lift0. split. eauto. rewrite firstn_skipn. rewrite firstn_skipn in All2_skipn. @@ -781,11 +781,11 @@ Lemma Construct_Ind_ind_eq' {cf:checker_flags} {Σ} (wfΣ : wf Σ.1): Σ ;;; Γ |- mkApps (tConstruct i n u) args : mkApps (tInd i' u') args' -> ∑ mdecl idecl cdecl, declared_constructor Σ.1 (i, n) mdecl idecl cdecl × - (i = i') * + (i = i') * (* Universe instances match *) R_ind_universes Σ i (context_assumptions (ind_params mdecl) + #|cstr_indices cdecl|) u u' * - consistent_instance_ext Σ (ind_universes mdecl) u * - consistent_instance_ext Σ (ind_universes mdecl) u' * + consistent_instance_ext Σ (ind_universes mdecl) u * + consistent_instance_ext Σ (ind_universes mdecl) u' * (#|args| = (ind_npars mdecl + context_assumptions cdecl.(cstr_args))%nat) * ∑ parsubst argsubst parsubst' argsubst', let parctx := (subst_instance u (ind_params mdecl)) in @@ -797,21 +797,21 @@ Lemma Construct_Ind_ind_eq' {cf:checker_flags} {Σ} (wfΣ : wf Σ.1): ((subst_context (inds (inductive_mind i) u' mdecl.(ind_bodies)) #|ind_params mdecl| (subst_instance u' cdecl.(cstr_args))))) in let argctx' := (subst_context parsubst' 0 (subst_instance u' idecl.(ind_indices))) in - + [× spine_subst Σ Γ (firstn (ind_npars mdecl) args) parsubst parctx, spine_subst Σ Γ (firstn (ind_npars mdecl) args') parsubst' parctx', spine_subst Σ Γ (skipn (ind_npars mdecl) args) argsubst argctx, spine_subst Σ Γ (skipn (ind_npars mdecl) args') argsubst' argctx' & - ∑ s, + ∑ s, sorts_local_ctx (lift_typing typing) Σ Γ argctx2 s × (** Parameters match *) ws_cumul_pb_terms Σ Γ (firstn mdecl.(ind_npars) args) (firstn mdecl.(ind_npars) args') × (** Indices match *) ws_cumul_pb_terms Σ Γ - (map (subst0 (argsubst ++ parsubst) ∘ + (map (subst0 (argsubst ++ parsubst) ∘ subst (inds (inductive_mind i) u mdecl.(ind_bodies)) (#|cdecl.(cstr_args)| + #|ind_params mdecl|) - ∘ (subst_instance u)) + ∘ (subst_instance u)) cdecl.(cstr_indices)) (skipn mdecl.(ind_npars) args') ]. Proof. @@ -833,7 +833,7 @@ Lemma conv_decls_fix_context_gen {cf:checker_flags} Σ Γ mfix mfix1 : forall Γ' Γ'', Σ ⊢ Γ ,,, Γ' = Γ ,,, Γ'' -> ws_cumul_ctx_pb_rel Conv Σ (Γ ,,, Γ') (fix_context_gen #|Γ'| mfix) (fix_context_gen #|Γ''| mfix1). -Proof. +Proof. intros wfΣ a Γ' Γ'' convctx. split. eauto with fvs. induction a in Γ', Γ'', convctx |- *. constructor. simpl. @@ -865,7 +865,7 @@ Lemma conv_decls_fix_context {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ mfix mfi All2 (fun d d' => Σ ;;; Γ ⊢ d.(dtype) = d'.(dtype) × eq_binder_annot d.(dname) d'.(dname)) mfix mfix1 -> All2_fold (fun Δ Δ' : context => decl_ws_cumul_pb Σ (Γ ,,, Δ)) (fix_context mfix) (fix_context mfix1). -Proof. +Proof. intros wfΓ a. apply (conv_decls_fix_context_gen _ _ _ _ wfΣ a [] []). eapply ws_cumul_ctx_pb_refl. eauto with fvs. @@ -908,7 +908,7 @@ Proof. depelim p; cbn; lia. Qed. -Lemma invert_Case_Construct {cf:checker_flags} Σ (hΣ : ∥ wf Σ.1 ∥) +Lemma invert_Case_Construct {cf:checker_flags} Σ (hΣ : ∥ wf Σ.1 ∥) {Γ ci ind' pred i u brs args T} : Σ ;;; Γ |- tCase ci pred (mkApps (tConstruct ind' i u) args) brs : T -> ci.(ci_ind) = ind' /\ @@ -1067,7 +1067,7 @@ Qed. Lemma projection_context_gen_inst {cf} {Σ mdecl idecl ind u} : declared_inductive Σ.1 ind mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> - (projection_context_gen ind mdecl idecl)@[u] = + (projection_context_gen ind mdecl idecl)@[u] = projection_context ind mdecl idecl u. Proof. intros isdecl cu. @@ -1096,7 +1096,7 @@ Proof. induction subs in s, subl |- *. * cbn. intros. constructor. * cbn. rewrite subst_context_snoc. constructor; auto. - eapply substitution in t0; tea. + eapply substitution in t0; tea. cbn. rewrite -(subslet_length subs). now rewrite -distr_subst. * cbn. rewrite subst_context_snoc. @@ -1110,8 +1110,8 @@ Proof. Qed. Lemma weaken_wf_subslet {cf Σ} {wfΣ : wf Σ} s (Δ Γ Γ' : context) : - wf_local Σ Γ → - wf_subslet Σ Γ' s Δ → + wf_local Σ Γ → + wf_subslet Σ Γ' s Δ → wf_subslet Σ (Γ,,, Γ') s Δ. Proof. intros wfΓ [wf subs]. split. @@ -1122,8 +1122,8 @@ Proof. Qed. Lemma on_projections_indices {mdecl i idecl cs} : - on_projections mdecl (inductive_mind i) (inductive_ind i) - idecl (ind_indices idecl) cs -> + on_projections mdecl (inductive_mind i) (inductive_ind i) + idecl (ind_indices idecl) cs -> idecl.(ind_indices) = []. Proof. move/on_projs_noidx. destruct ind_indices; try discriminate; auto. @@ -1133,9 +1133,9 @@ Qed. Lemma subslet_projs {cf:checker_flags} {Σ} {wfΣ : wf Σ} {i mdecl idecl args} : declared_inductive Σ.1 i mdecl idecl -> match ind_ctors idecl return Type with - | [cs] => - on_projections mdecl (inductive_mind i) (inductive_ind i) - idecl (ind_indices idecl) cs -> + | [cs] => + on_projections mdecl (inductive_mind i) (inductive_ind i) + idecl (ind_indices idecl) cs -> forall Γ t u, let indsubst := inds (inductive_mind i) u (ind_bodies mdecl) in Σ;;; Γ |- t : mkApps (tInd i u) args -> @@ -1151,10 +1151,10 @@ Lemma subslet_projs {cf:checker_flags} {Σ} {wfΣ : wf Σ} {i mdecl idecl args} Proof. intros Hdecl. destruct ind_ctors as [|cs []] eqn:Heq; trivial. - intros onp. simpl. intros Γ t u. + intros onp. simpl. intros Γ t u. rewrite (smash_context_subst []). assert (#|PCUICEnvironment.ind_projs idecl| >= - PCUICEnvironment.context_assumptions (cstr_args cs)). + PCUICEnvironment.context_assumptions (cstr_args cs)). { destruct onp. lia. } intros Ht. epose proof (declared_projections_subslet _ Hdecl cs Heq onp _ (Nat.le_refl _)). @@ -1190,14 +1190,14 @@ Proof. rewrite subst_instance_smash //. Qed. -Ltac unf_env := - change PCUICEnvironment.it_mkProd_or_LetIn with it_mkProd_or_LetIn in *; - change PCUICEnvironment.to_extended_list_k with to_extended_list_k in *; +Ltac unf_env := + change PCUICEnvironment.it_mkProd_or_LetIn with it_mkProd_or_LetIn in *; + change PCUICEnvironment.to_extended_list_k with to_extended_list_k in *; change PCUICEnvironment.ind_params with ind_params in *. Derive Signature for positive_cstr. -Lemma positive_cstr_it_mkProd_or_LetIn mdecl i Γ Δ t : +Lemma positive_cstr_it_mkProd_or_LetIn mdecl i Γ Δ t : positive_cstr mdecl i Γ (it_mkProd_or_LetIn Δ t) -> All_local_env (fun Δ ty _ => positive_cstr_arg mdecl (Γ ,,, Δ) ty) (smash_context [] Δ) * @@ -1230,7 +1230,7 @@ Proof. rewrite subst_app_simpl; len => /=. simpl. rewrite subst_context_lift_id. - rewrite Nat.add_comm Nat.add_1_r subst_reli_lift_id. + rewrite Nat.add_comm Nat.add_1_r subst_reli_lift_id. apply context_assumptions_length_bound. now rewrite app_context_assoc. Qed. @@ -1260,7 +1260,7 @@ Proof. now rewrite /expand_lets expand_lets_k_app. Qed. -Lemma closedn_expand Γ Δ x : +Lemma closedn_expand Γ Δ x : closed_ctx Γ -> closedn (context_assumptions Δ + #|Γ|) (expand_lets Δ x) = closedn (context_assumptions Δ + context_assumptions Γ) (expand_lets (Γ ,,, Δ) x). @@ -1272,7 +1272,7 @@ Proof. erewrite (closedn_expand_lets_eq 0) => /= //. now cbn. Qed. -Lemma closedn_expand' (Γ Δ : context) x : +Lemma closedn_expand' (Γ Δ : context) x : closedn_ctx #|Γ| Δ -> closedn (context_assumptions Δ + #|Γ|) (expand_lets Δ x) -> closedn (#|Δ| + #|Γ|) x. @@ -1286,7 +1286,7 @@ Proof. lia. Qed. -Lemma positive_cstr_closed_indices {cf} {Σ} {wfΣ : wf Σ} : +Lemma positive_cstr_closed_indices {cf} {Σ} {wfΣ : wf Σ} : forall {i mdecl idecl cdecl}, declared_constructor Σ.1 i mdecl idecl cdecl -> All (closedn (context_assumptions (cstr_args cdecl) + #|ind_params mdecl|)) @@ -1331,7 +1331,7 @@ Qed. Import ssrbool. -Lemma invert_red_mkApps_tRel {cf} {Σ} {wfΣ : wf Σ} {Γ n d args t'} : +Lemma invert_red_mkApps_tRel {cf} {Σ} {wfΣ : wf Σ} {Γ n d args t'} : nth_error Γ n = Some d -> decl_body d = None -> Σ ;;; Γ ⊢ mkApps (tRel n) args ⇝ t' -> ∑ args' : list term, t' = mkApps (tRel n) args' × red_terms Σ Γ args args'. @@ -1346,9 +1346,9 @@ Proof. eapply into_closed_red; eauto. Qed. -Lemma ws_cumul_pb_mkApps_tRel {cf} {Σ} {wfΣ : wf Σ} {Γ n d u u'} : +Lemma ws_cumul_pb_mkApps_tRel {cf} {Σ} {wfΣ : wf Σ} {Γ n d u u'} : nth_error Γ n = Some d -> decl_body d = None -> - Σ ;;; Γ ⊢ mkApps (tRel n) u ≤ mkApps (tRel n) u' -> + Σ ;;; Γ ⊢ mkApps (tRel n) u ≤ mkApps (tRel n) u' -> ws_cumul_pb_terms Σ Γ u u'. Proof. intros Hnth Hd cum. @@ -1367,14 +1367,14 @@ Proof. all:solve_all. Qed. -Lemma nth_error_subst_instance u Γ n : - nth_error (subst_instance u Γ) n = +Lemma nth_error_subst_instance u Γ n : + nth_error (subst_instance u Γ) n = option_map (map_decl (subst_instance u)) (nth_error Γ n). Proof. now rewrite nth_error_map. Qed. -Lemma ws_cumul_pb_terms_confl {cf} {Σ} {wfΣ : wf Σ} {Γ u u'} : +Lemma ws_cumul_pb_terms_confl {cf} {Σ} {wfΣ : wf Σ} {Γ u u'} : ws_cumul_pb_terms Σ Γ u u' -> ∑ nf nf', (red_terms Σ Γ u nf * red_terms Σ Γ u' nf') * (All2 (eq_term Σ Σ) nf nf'). Proof. @@ -1386,7 +1386,7 @@ Proof. exists (x' :: nf), (y' :: nf'); intuition auto. Qed. -Lemma closed_red_mkApps {cf} {Σ} {wfΣ : wf Σ} Γ f u u' : +Lemma closed_red_mkApps {cf} {Σ} {wfΣ : wf Σ} Γ f u u' : is_closed_context Γ -> is_open_term Γ f -> red_terms Σ Γ u u' -> @@ -1400,7 +1400,7 @@ Proof. eapply closed_red_terms_open_left in red; solve_all. Qed. -Lemma ws_cumul_pb_mkApps_eq {cf} {Σ} {wfΣ : wf Σ} Γ f f' u u' : +Lemma ws_cumul_pb_mkApps_eq {cf} {Σ} {wfΣ : wf Σ} Γ f f' u u' : is_closed_context Γ -> is_open_term Γ f -> is_open_term Γ f' -> @@ -1456,7 +1456,7 @@ Proof. eapply ws_cumul_pb_ws_cumul_ctx; tea. constructor; auto. eapply ws_cumul_ctx_pb_refl. eauto with fvs. constructor; auto. exact p0. -Qed. +Qed. Lemma inds_is_open_terms (Γ : context) ind mdecl u : forallb (is_open_term Γ) (inds (inductive_mind ind) u (ind_bodies mdecl)). @@ -1486,7 +1486,7 @@ Lemma positive_cstr_arg_subst {cf} {Σ} {wfΣ : wf Σ} {ind mdecl idecl Γ t u u closed_ctx (ind_arities mdecl ,,, Γ)@[u] -> Σ ;;; subst_instance u (ind_arities mdecl) ,,, subst_instance u Γ ⊢ (subst_instance u t) ≤ (subst_instance u' t) -> positive_cstr_arg mdecl Γ t -> - (Σ ;;; subst_context (ind_subst mdecl ind u) 0 (subst_instance u Γ) ⊢ + (Σ ;;; subst_context (ind_subst mdecl ind u) 0 (subst_instance u Γ) ⊢ (subst (ind_subst mdecl ind u) #|Γ| (subst_instance u t)) ≤ subst (ind_subst mdecl ind u') #|Γ| (subst_instance u' t)). Proof. @@ -1552,10 +1552,10 @@ Proof. rewrite (Nat.leb_refl) //. eapply Nat.leb_nle in eqle. lia. * do 2 eapply All2_map. do 2 eapply All2_map_inv in cum. eapply All2_All in cum. apply All_All2_refl. - solve_all. + solve_all. now rewrite !subst_closedn ?closedn_subst_instance // in b |- *. - - simpl. simpl in cum. + - simpl. simpl in cum. eapply ws_cumul_pb_LetIn_subst. eauto. { rewrite -(app_context_nil_l (_ ,,, _)) app_context_assoc in cum. eapply substitution_ws_cumul_pb in cum. @@ -1598,7 +1598,7 @@ Lemma positive_cstr_closed_args_subst_arities {cf} {Σ} {wfΣ : wf Σ} {u u' Γ} {i ind mdecl idecl cdecl ind_indices cs} : declared_inductive Σ ind mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> - on_constructor cumulSpec0 (lift_typing typing) (Σ.1, ind_universes mdecl) mdecl i idecl ind_indices cdecl cs -> + on_constructor cumulSpec0 (lift_typing typing) (Σ.1, ind_universes mdecl) mdecl i idecl ind_indices cdecl cs -> R_opt_variance (eq_universe Σ) (leq_universe Σ) (ind_variance mdecl) u u' -> closed_ctx (subst_instance u (ind_params mdecl)) -> wf_local Σ (subst_instance u (ind_arities mdecl ,,, smash_context [] (ind_params mdecl) ,,, Γ)) -> @@ -1610,7 +1610,7 @@ Lemma positive_cstr_closed_args_subst_arities {cf} {Σ} {wfΣ : wf Σ} {u u' Γ} ws_cumul_ctx_pb_rel Cumul Σ (subst_instance u (ind_arities mdecl) ,,, subst_instance u (smash_context [] (PCUICEnvironment.ind_params mdecl))) - (subst_instance u Γ) (subst_instance u' Γ) -> + (subst_instance u Γ) (subst_instance u' Γ) -> ws_cumul_ctx_pb_rel Cumul Σ (subst_instance u (smash_context [] (PCUICEnvironment.ind_params mdecl))) (subst_context (ind_subst mdecl ind u) (context_assumptions (ind_params mdecl)) (subst_instance u Γ)) (subst_context (ind_subst mdecl ind u') (context_assumptions (ind_params mdecl)) (subst_instance u' Γ)). @@ -1651,7 +1651,7 @@ Proof. - elimtype False; now depelim ass. Qed. -Lemma positive_cstr_closed_args {cf} {Σ} {wfΣ : wf Σ} {u u'} +Lemma positive_cstr_closed_args {cf} {Σ} {wfΣ : wf Σ} {u u'} {ind mdecl idecl cdecl} : declared_constructor Σ ind mdecl idecl cdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> @@ -1741,10 +1741,10 @@ Section Betweenu. Definition betweenu_universe0 (u : LevelAlgExpr.t) := LevelExprSet.for_all betweenu_level_expr u. - + Definition betweenu_universe (u : Universe.t) := - match u with - | Universe.lProp | Universe.lSProp => true + match u with + | Universe.lProp | Universe.lSProp => true | Universe.lType l => betweenu_universe0 l end. @@ -1771,7 +1771,7 @@ Section UniverseClosedSubst. rewrite app_nth2; try lia. lia_f_equal. Qed. - + Lemma closedu_subst_instance_level_expr_app u u' e : closedu_level_expr #|u'| e -> subst_instance_level_expr (u' ++ u) e = subst_instance_level_expr u' e. Proof. @@ -1788,14 +1788,14 @@ Section UniverseClosedSubst. intros Hn % Nat.ltb_lt. rewrite nth_error_app_lt //. Qed. *) - + Lemma closedu_subst_instance_app u u' t : closedu_instance #|u'| t -> subst_instance (u' ++ u) t = subst_instance u' t. Proof. intro H. eapply forallb_All in H. apply All_map_eq. solve_all. now eapply closedu_subst_instance_level_app. Qed. - + Lemma closedu_subst_instance_lift u u' t : closedu_instance #|u| t -> subst_instance (u' ++ u) (lift_instance #|u'| t) = subst_instance u t. Proof. @@ -1803,7 +1803,7 @@ Section UniverseClosedSubst. rewrite /subst_instance /subst_instance_instance /lift_instance map_map_compose. apply All_map_eq. solve_all. now eapply closedu_subst_instance_level_lift. Qed. - + End UniverseClosedSubst. Lemma level_var_instance_length n i : #|level_var_instance n i| = #|i|. @@ -1822,7 +1822,7 @@ Lemma variance_universes_insts {cf} {Σ mdecl l} : [× variance_universes (PCUICEnvironment.ind_universes mdecl) l = Some (v, i, i'), match ind_universes mdecl with | Monomorphic_ctx => False - | Polymorphic_ctx (inst, cstrs) => + | Polymorphic_ctx (inst, cstrs) => let cstrs := ConstraintSet.union (ConstraintSet.union cstrs (lift_constraints #|i| cstrs)) (variance_cstrs l i i') in v = Polymorphic_ctx (inst ++ inst, cstrs) end, @@ -1847,12 +1847,12 @@ Qed. Lemma consistent_instance_poly_length {cf} {Σ} {wfΣ : wf Σ} {inst cstrs u} : consistent_instance_ext Σ (Polymorphic_ctx (inst, cstrs)) u -> - #|u| = #|inst|. + #|u| = #|inst|. Proof. rewrite /consistent_instance_ext /consistent_instance. intuition auto. Qed. - + Lemma consistent_instance_valid {cf} {Σ} {wfΣ : wf Σ} {inst cstrs u} : consistent_instance_ext Σ (Polymorphic_ctx (inst, cstrs)) u -> check_univs -> @@ -1863,7 +1863,7 @@ Qed. Definition closedu_cstr k (cstr : (Level.t * ConstraintType.t * Level.t)) := let '(l1, p, l2) := cstr in - closedu_level k l1 && closedu_level k l2. + closedu_level k l1 && closedu_level k l2. Definition closedu_cstrs k (cstrs : CS.t) := CS.For_all (closedu_cstr k) cstrs. @@ -1883,7 +1883,7 @@ Proof. specialize (IHinst _ H). now rewrite Nat.add_succ_r. Qed. -Lemma LSet_in_global_bounded {cf:checker_flags} {Σ : global_env} {l} k : +Lemma LSet_in_global_bounded {cf:checker_flags} {Σ : global_env} {l} k : wf Σ -> LevelSet.In l (global_levels Σ) -> closedu_level k l. Proof. @@ -1919,7 +1919,7 @@ Proof. Qed. Lemma closedu_subst_instance_cstrs_app u u' cstrs : - closedu_cstrs #|u| cstrs -> + closedu_cstrs #|u| cstrs -> CS.Equal (subst_instance_cstrs (u ++ u') cstrs) (subst_instance_cstrs u cstrs). Proof. intros clcstra. @@ -1979,7 +1979,7 @@ Qed. Lemma closedu_subst_instance_cstrs_lift u u' cstrs : - closedu_cstrs #|u'| cstrs -> + closedu_cstrs #|u'| cstrs -> CS.Equal (subst_instance_cstrs (u ++ u') (lift_constraints #|u| cstrs)) (subst_instance_cstrs u' cstrs). Proof. intros clcstra. @@ -2007,7 +2007,7 @@ Proof. rewrite !closedu_subst_instance_level_lift //. Qed. -Lemma subst_instance_cstrs_add u x c : +Lemma subst_instance_cstrs_add u x c : CS.Equal (subst_instance_cstrs u (ConstraintSet.add x c)) (ConstraintSet.add (subst_instance_cstr u x) (subst_instance_cstrs u c)). Proof. @@ -2044,7 +2044,7 @@ Qed. Lemma is_closed_subst_inst Γ u : is_closed_context Γ@[u] = is_closed_context Γ. Proof. rewrite -(app_context_nil_l Γ@[u]). - rewrite is_closed_context_subst_instance app_context_nil_l //. + rewrite is_closed_context_subst_instance app_context_nil_l //. Qed. (** Morally, if variance_universes l = v i i' and R_universe_instance_variance l u u' then @@ -2053,7 +2053,7 @@ Qed. i and i' by u and u'. *) -Lemma ws_cumul_pb_inst_variance {cf} {le} {Σ} {wfΣ : wf Σ} {mdecl l v i i' u u' Γ} : +Lemma ws_cumul_pb_inst_variance {cf} {le} {Σ} {wfΣ : wf Σ} {mdecl l v i i' u u' Γ} : on_udecl_prop Σ (ind_universes mdecl) -> on_variance Σ (ind_universes mdecl) (Some l) -> variance_universes (PCUICEnvironment.ind_universes mdecl) l = Some (v, i, i') -> @@ -2081,7 +2081,7 @@ Proof. assert (subst_instance (u' ++ u) i' = u') as subsu'. { rewrite closedu_subst_instance_app //. rewrite H0 //. rewrite eqi' //. - erewrite subst_instance_id_mdecl => //. eauto. } + erewrite subst_instance_id_mdecl => //. eauto. } eapply (subst_instance_ws_cumul_pb (Σ, v) _ (u' ++ u)) in cum; auto. rewrite !subst_instance_two in cum. rewrite subst_instance_two_context in cum. @@ -2139,7 +2139,7 @@ Proof. constructor. now rewrite !Universes.LevelAlgExpr.val_make in Ra. Qed. -Lemma All2_fold_inst {cf} {le} {Σ} {wfΣ : wf Σ} mdecl l v i i' u u' Γ' Γ : +Lemma All2_fold_inst {cf} {le} {Σ} {wfΣ : wf Σ} mdecl l v i i' u u' Γ' Γ : on_udecl_prop Σ (ind_universes mdecl) -> on_variance Σ (ind_universes mdecl) (Some l) -> consistent_instance_ext Σ (ind_universes mdecl) u -> @@ -2169,7 +2169,7 @@ Proof. cbn. eapply ws_cumul_pb_inst_variance; eauto. - intros H; depelim H; simpl in *. depelim a. - constructor; auto. + constructor; auto. rewrite !is_closed_subst_inst // in i0 *. constructor; auto. now apply IHtl. @@ -2179,7 +2179,7 @@ Proof. depelim a0; constructor; eauto using ws_cumul_pb_inst_variance. Qed. -Lemma forallb_closed_upwards k k' s : +Lemma forallb_closed_upwards k k' s : forallb (closedn k) s -> k <= k' -> forallb (closedn k') s. @@ -2194,8 +2194,8 @@ Lemma subst_context_subst_context s k s' Γ : subst_context s k (subst_context s' 0 Γ) = subst_context (map (subst s k) s') 0 (subst_context s (k + #|s'|) Γ). Proof. - induction Γ as [|[na [b|] ty] Γ']; simpl; auto; - rewrite !subst_context_snoc /= /subst_decl /map_decl /=; f_equal; + induction Γ as [|[na [b|] ty] Γ']; simpl; auto; + rewrite !subst_context_snoc /= /subst_decl /map_decl /=; f_equal; auto; f_equal; len; rewrite distr_subst_rec; lia_f_equal. Qed. @@ -2206,8 +2206,8 @@ Lemma subst_context_subst_context_comm s k k' s' Γ : subst_context s' k (subst_context (map (lift0 #|s'|) s) k Γ). Proof. intros ->. - induction Γ as [|[na [b|] ty] Γ']; simpl; auto; - rewrite !subst_context_snoc /= /subst_decl /map_decl /=; f_equal; + induction Γ as [|[na [b|] ty] Γ']; simpl; auto; + rewrite !subst_context_snoc /= /subst_decl /map_decl /=; f_equal; auto; f_equal; len; now rewrite Nat.add_assoc -subst_app_simpl subst_app_decomp. Qed. @@ -2258,7 +2258,7 @@ Proof. Qed. Lemma subst_instance_expand_lets u Γ t : - subst_instance u (expand_lets Γ t) = + subst_instance u (expand_lets Γ t) = expand_lets (subst_instance u Γ) (subst_instance u t). Proof. rewrite /expand_lets /expand_lets_k. @@ -2281,7 +2281,7 @@ Proof. Qed. Lemma cumul_ctx_relSpec_Algo {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} - (c : cumul_ctx_rel cumulSpec0 Σ Γ Δ Δ') : + (c : cumul_ctx_rel cumulSpec0 Σ Γ Δ Δ') : is_closed_context (Γ ,,, Δ) -> is_closed_context (Γ ,,, Δ') -> ws_cumul_ctx_pb_rel Cumul Σ Γ Δ Δ'. @@ -2307,7 +2307,7 @@ Proof. Qed. Lemma into_ws_cumul_ctx_pb_rel {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} - (c : cumul_ctx_rel cumulAlgo_gen Σ Γ Δ Δ') : + (c : cumul_ctx_rel cumulAlgo_gen Σ Γ Δ Δ') : is_closed_context (Γ ,,, Δ) -> is_closed_context (Γ ,,, Δ') -> ws_cumul_ctx_pb_rel Cumul Σ Γ Δ Δ'. @@ -2318,7 +2318,7 @@ Proof. apply All2_fold_app; auto. reflexivity. Qed. -Lemma is_closed_context_weaken Γ Δ : +Lemma is_closed_context_weaken Γ Δ : is_closed_context Γ -> is_closed_context Δ -> is_closed_context (Γ ,,, Δ). @@ -2335,7 +2335,7 @@ Lemma inductive_cumulative_indices {cf} {Σ} {wfΣ : wf Σ} : R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) napp u u' -> forall Γ pars pars' parsubst parsubst', spine_subst Σ Γ pars parsubst (subst_instance u (ind_params mdecl)) -> - spine_subst Σ Γ pars' parsubst' (subst_instance u' (ind_params mdecl)) -> + spine_subst Σ Γ pars' parsubst' (subst_instance u' (ind_params mdecl)) -> ws_cumul_pb_terms Σ Γ pars pars' -> let indctx := subst_instance u idecl.(ind_indices) in let indctx' := subst_instance u' idecl.(ind_indices) in @@ -2383,7 +2383,7 @@ Proof. destruct global_variance eqn:gv. { move:gv. simpl. rewrite (declared_inductive_lookup decli). - rewrite oib.(ind_arity_eq). + rewrite oib.(ind_arity_eq). rewrite !destArity_it_mkProd_or_LetIn. simpl. rewrite app_context_nil_l context_assumptions_app. elim: leb_spec_Set => // comp. @@ -2453,7 +2453,7 @@ Proof. rewrite -(subst_instance_smash u' _ []). eapply subst_instance_ws_cumul_ctx_pb_rel => //. rewrite -app_context_assoc. - rewrite is_closed_context_weaken //. + rewrite is_closed_context_weaken //. eapply spine_dom_wf in spu. eauto with fvs. rewrite -(is_closed_context_subst_instance _ _ u). rewrite -subst_instance_app_ctx. @@ -2466,7 +2466,7 @@ Qed. #[global] Hint Resolve declared_inductive_minductive : core. #[global] Hint Resolve declared_constructor_inductive : core. -Lemma into_ws_cumul_pb_terms {cf} {Σ} {wfΣ : wf Σ} {Γ l l'} : +Lemma into_ws_cumul_pb_terms {cf} {Σ} {wfΣ : wf Σ} {Γ l l'} : All2 (convSpec Σ Γ) l l' -> is_closed_context Γ -> forallb (is_open_term Γ) l -> @@ -2477,7 +2477,7 @@ Proof. eapply convSpec_convAlgo_curry in b0; tea. Qed. -Lemma on_constructor_closed_indices {cf} {Σ} {wfΣ : wf Σ} : +Lemma on_constructor_closed_indices {cf} {Σ} {wfΣ : wf Σ} : forall {i mdecl idecl cdecl}, declared_constructor Σ.1 i mdecl idecl cdecl -> All (is_open_term (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, cstr_args cdecl)) (cstr_indices cdecl). @@ -2488,7 +2488,7 @@ Proof. now eapply ctx_inst_open_terms in X. Qed. -Lemma positive_cstr_closed_indices' {cf} {Σ} {wfΣ : wf Σ} : +Lemma positive_cstr_closed_indices' {cf} {Σ} {wfΣ : wf Σ} : forall {i mdecl idecl cdecl}, declared_constructor Σ.1 i mdecl idecl cdecl -> All (closedn (context_assumptions (cstr_args cdecl) + context_assumptions (ind_params mdecl))) @@ -2513,17 +2513,17 @@ Proof. eapply All_map; eapply (All_impl a); intros x; len. Qed. -Lemma closedn_expand'' (Γ : context) x : +Lemma closedn_expand'' (Γ : context) x : closedn (context_assumptions Γ) (expand_lets Γ x) -> closedn #|Γ| x. Proof. eapply (closedn_expand_lets 0). Qed. -Lemma subst_context_expand_lets_k s Γ Δ : +Lemma subst_context_expand_lets_k s Γ Δ : closed_ctx Γ -> subst_context s (context_assumptions Γ) (expand_lets_ctx Γ Δ) = expand_lets_ctx Γ (subst_context s #|Γ| Δ). -Proof. +Proof. intros cl. rewrite /expand_lets_ctx /expand_lets_k_ctx. rewrite subst_subst_context. @@ -2561,9 +2561,9 @@ Lemma constructor_cumulative_indices {cf} {Σ} {wfΣ : wf Σ} : R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef c.1) napp u u' -> forall Γ pars pars' parsubst parsubst', spine_subst Σ Γ pars parsubst (subst_instance u (ind_params mdecl)) -> - spine_subst Σ Γ pars' parsubst' (subst_instance u' (ind_params mdecl)) -> + spine_subst Σ Γ pars' parsubst' (subst_instance u' (ind_params mdecl)) -> ws_cumul_pb_terms Σ Γ pars pars' -> - let argctx := + let argctx := (subst_context (ind_subst mdecl c.1 u) #|ind_params mdecl| (subst_instance u (cstr_args cdecl))) in let argctx' := @@ -2582,7 +2582,7 @@ Proof. destruct (on_declared_constructor declc) as [[onmind oib] [cs [hnth onc]]]. intros cu cu' Ru Γ * spu spu' cpars *. move: Ru. assert (onu : on_udecl_prop Σ (ind_universes mdecl)). - { eapply (weaken_lookup_on_global_env' _ _ _ wfΣ (proj1 (proj1 declc))). } + { eapply (weaken_lookup_on_global_env' _ _ _ wfΣ (proj1 (proj1 declc))). } have clΓ : is_closed_context Γ. { apply spine_dom_wf in spu; eauto with fvs. } unfold R_global_instance. @@ -2605,7 +2605,7 @@ Proof. destruct global_variance eqn:gv. { move:gv. simpl. rewrite (declared_inductive_lookup declc). - rewrite oib.(ind_arity_eq). + rewrite oib.(ind_arity_eq). rewrite !destArity_it_mkProd_or_LetIn. simpl. rewrite app_context_nil_l context_assumptions_app. elim: leb_spec_Set => // comp. @@ -2628,7 +2628,7 @@ Proof. (expand_lets_ctx (PCUICEnvironment.ind_params mdecl) (cstr_args cdecl))))). { pose proof (on_constructor_wf_args declc). - eapply (wf_local_subst_instance _ _ _ u) in X; tea. + eapply (wf_local_subst_instance _ _ _ u) in X; tea. 2:{ apply (declared_inductive_wf_global_ext _ _ _ _ declc). } rewrite subst_instance_expand_lets_ctx. rewrite -(expand_lets_smash_context _ []). @@ -2652,7 +2652,7 @@ Proof. rewrite !subst_instance_smash /= in args. rewrite subst_instance_app_ctx in args. eapply positive_cstr_closed_args in args; eauto. - 2:{ rewrite indv. now simpl. } + 2:{ rewrite indv. now simpl. } rewrite - !smash_context_subst !subst_context_nil in args. eapply (weaken_ws_cumul_ctx_pb_rel (Γ := Γ)) in args => //. pose proof (spine_subst_smash spu) as sspu. @@ -2745,7 +2745,7 @@ Proof. eapply All_All2; tea. solve_all. rename a into clx; rename b into cxy. rewrite -app_context_assoc. eapply weaken_ws_cumul_pb; eauto. - + (* eapply All_mix in idx; tea. clear cli. *) rewrite smash_context_app smash_context_acc in cxy. (* rename a into clx; rename b into cxy. @@ -2755,7 +2755,7 @@ Proof. (* rewrite !app_context_nil_l in X3. eapply X3 in cxy; clear X3; cycle 1. *) rewrite subst_instance_app_ctx in cxy. epose proof (subst_conv_closed (Γ := [])) as X3. - rewrite !app_context_nil_l in X3. eapply X3 in cxy; clear X3; cycle 1. + rewrite !app_context_nil_l in X3. eapply X3 in cxy; clear X3; cycle 1. { eapply (subslet_inds (u:=u)); eauto. } { eapply (subslet_inds (u:=u')); eauto. } { now len. } @@ -2807,7 +2807,7 @@ Proof. eapply subst_instance_ws_cumul_ctx_pb_rel; eauto with fvs. move: clΓparsu. now rewrite is_closed_context_subst_instance. } simpl. - assert (subst_context (ind_subst mdecl c.1 u) 0 (subst_instance u (ind_params mdecl)) = + assert (subst_context (ind_subst mdecl c.1 u) 0 (subst_instance u (ind_params mdecl)) = (subst_instance u (ind_params mdecl))) as ispars. { rewrite closed_ctx_subst; eauto. } rewrite -ispars. @@ -2867,12 +2867,12 @@ Proof. rewrite -is_open_term_closed. len. rewrite -context_assumptions_app in H. eapply closedn_expand'' in H => //. - substu. eapply closed_upwards; tea. len. } + substu. eapply closed_upwards; tea. len. } { rewrite /argctx'. rewrite -is_open_term_closed. len. rewrite -context_assumptions_app in H. eapply closedn_expand'' in H => //. - substu. eapply closed_upwards; tea. len. } + substu. eapply closed_upwards; tea. len. } rewrite /argctx /argctx'. eapply weaken_ws_cumul_ctx_pb_rel. eauto with fvs. rewrite /ind_subst. @@ -2900,19 +2900,19 @@ Proof. now do 2 apply assumption_context_fold. Qed. -Lemma assumption_context_subst_context s k Γ : +Lemma assumption_context_subst_context s k Γ : assumption_context Γ -> assumption_context (subst_context s k Γ). Proof. apply assumption_context_fold. Qed. -Lemma assumption_context_lift_context s k Γ : +Lemma assumption_context_lift_context s k Γ : assumption_context Γ -> assumption_context (lift_context s k Γ). Proof. apply assumption_context_fold. Qed. #[global] -Hint Resolve assumption_context_fold assumption_context_expand_lets_ctx - smash_context_assumption_context assumption_context_nil assumption_context_subst_instance +Hint Resolve assumption_context_fold assumption_context_expand_lets_ctx + smash_context_assumption_context assumption_context_nil assumption_context_subst_instance assumption_context_subst_context assumption_context_lift_context : pcuic. Lemma subst_inds_smash_params {cf} {Σ} {wfΣ : wf Σ} {mdecl ind idecl u} : @@ -2930,8 +2930,8 @@ Proof. now eapply on_minductive_wf_params; pcuic. Qed. -Lemma nth_error_expand_lets Γ Δ n : - nth_error (expand_lets_ctx Γ Δ) n = +Lemma nth_error_expand_lets Γ Δ n : + nth_error (expand_lets_ctx Γ Δ) n = option_map (map_decl (expand_lets_k Γ (#|Δ| - S n))) (nth_error Δ n). Proof. rewrite /expand_lets_ctx /expand_lets_k_ctx nth_error_subst_context; len. @@ -2946,12 +2946,12 @@ Proof. Qed. Lemma subslet_projs_smash {cf:checker_flags} (Σ : global_env_ext) i mdecl idecl : - forall (wfΣ : wf Σ.1) + forall (wfΣ : wf Σ.1) (Hdecl : declared_inductive Σ.1 i mdecl idecl), match ind_ctors idecl return Type with - | [cdecl] => - on_projections mdecl (inductive_mind i) (inductive_ind i) - idecl (ind_indices idecl) cdecl -> + | [cdecl] => + on_projections mdecl (inductive_mind i) (inductive_ind i) + idecl (ind_indices idecl) cdecl -> forall Γ t u, let indsubst := inds (inductive_mind i) u (ind_bodies mdecl) in untyped_subslet Γ @@ -2964,7 +2964,7 @@ Lemma subslet_projs_smash {cf:checker_flags} (Σ : global_env_ext) i mdecl idecl Proof. intros wfΣ Hdecl. destruct ind_ctors as [|cdecl []] eqn:hcdecl => //. - intros onp. simpl. intros Γ t u. + intros onp. simpl. intros Γ t u. destruct onp. assert (#|PCUICEnvironment.ind_projs idecl| >= PCUICEnvironment.context_assumptions (cstr_args cdecl)). lia. @@ -3010,7 +3010,7 @@ Proof. simpl in *. destruct ind_cunivs as [|? []] eqn:cseq => //. destruct onc as []. noconf e1. - simpl in *. + simpl in *. destruct s as [idecl' [idecl'nth _ _ pty pty']]. rewrite -pty. unfold R_global_instance in Ru. @@ -3019,14 +3019,14 @@ Proof. destruct declp' as [[[? ?] ?] ?]. red in H0. rewrite H0 H1 in Ru. rewrite oib.(ind_arity_eq) in Ru. - rewrite !destArity_it_mkProd_or_LetIn /= in Ru. + rewrite !destArity_it_mkProd_or_LetIn /= in Ru. destruct p0 as [p0 _]. destruct (context_assumptions _ <=? _) eqn:eq. - 2:{ + 2:{ rewrite app_context_nil_l context_assumptions_app in eq. eapply Nat.leb_nle in eq. - destruct onps. - apply length_nil in on_projs_noidx. + destruct onps. + apply length_nil in on_projs_noidx. rewrite on_projs_noidx in eq. simpl in *. rewrite p0.(onNpars) in eq. lia. } epose proof (declared_projection_closed declp). @@ -3055,7 +3055,7 @@ Proof. (expand_lets_ctx (PCUICEnvironment.ind_params mdecl) (cstr_args cdecl))))). { pose proof (on_constructor_wf_args declp). - eapply (wf_local_subst_instance _ _ _ u) in X; tea. + eapply (wf_local_subst_instance _ _ _ u) in X; tea. 2:{ apply (declared_inductive_wf_global_ext _ _ _ _ declp). } rewrite subst_instance_expand_lets_ctx. rewrite -(expand_lets_smash_context _ []). @@ -3073,7 +3073,7 @@ Proof. rewrite !on_free_vars_ctx_app is_closed_subst_inst !on_free_vars_ctx_app. rewrite expand_lets_smash_context /= //. len. } eapply (All2_fold_inst _ _ _ _ _ u u') in onctx; eauto. - 2:{ rewrite -eqv. + 2:{ rewrite -eqv. eapply (onVariance p0). } rewrite subst_instance_app_ctx in onctx. epose proof (positive_cstr_closed_args declp cu) as hpos. @@ -3094,7 +3094,7 @@ Proof. rewrite nth_error_subst_context nth_error_map nth_error_expand_lets idecl'nth. rewrite !subst_instance_length !expand_lets_ctx_length !smash_context_length /=. simpl. move=> [= <-]. simpl. - move=> [[Hd _] Hty]. + move=> [[Hd _] Hty]. depelim Hty; simpl in *. move: eqt. rewrite subst_instance_smash. len. simpl. @@ -3126,7 +3126,7 @@ Proof. rewrite /projection_type /=. fold (expand_lets_k (ind_params mdecl) p.(proj_arg) ty). rewrite projs_inst_skipn. - assert (context_assumptions (cstr_args cdecl) - + assert (context_assumptions (cstr_args cdecl) - S (context_assumptions (cstr_args cdecl) - S p.(proj_arg)) = p.(proj_arg)) as -> by lia. clear X. rewrite subst_instance_subst. @@ -3182,7 +3182,7 @@ Lemma ctx_inst_app_weak `{checker_flags} Σ (wfΣ : wf Σ.1) ind mdecl idecl (is consistent_instance_ext Σ (ind_universes mdecl) v -> ctx_inst Σ Γ params (List.rev (subst_instance v (ind_params mdecl))) -> Σ ;;; Γ ⊢ mkApps (tInd ind u) args ≤ mkApps (tInd ind v) (params ++ skipn (ind_npars mdecl) args) -> - ctx_inst Σ Γ (params ++ skipn (ind_npars mdecl) args) + ctx_inst Σ Γ (params ++ skipn (ind_npars mdecl) args) (List.rev (subst_instance v (ind_params mdecl ,,, ind_indices idecl))). Proof. intros [? ty_args] ? cparams cum. @@ -3217,7 +3217,7 @@ Proof. } lia. } - + pose proof (declared_minductive_ind_npars isdecl). eapply invert_cumul_ind_ind in cum as [[_ Ruv] conv]. rewrite -{1}(firstn_skipn (ind_npars mdecl) args) in conv. @@ -3264,7 +3264,7 @@ Proof. constructor; tea. eexists; eassumption. Qed. -Lemma isType_it_mkProd_or_LetIn {cf:checker_flags} {Σ Γ Δ T} : +Lemma isType_it_mkProd_or_LetIn {cf:checker_flags} {Σ Γ Δ T} : wf Σ.1 -> isType Σ (Γ ,,, Δ) T -> isType Σ Γ (it_mkProd_or_LetIn Δ T). @@ -3292,7 +3292,7 @@ Proof. depelim wf. destruct l as [s1 Hs1]. exists (Universe.sort_of_product s1 s). - econstructor; eauto. + econstructor; eauto. Qed. Lemma wf_set_binder_name {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {nas Δ} : @@ -3322,7 +3322,7 @@ Lemma WfArity_build_case_predicate_type {cf:checker_flags} {Σ Γ ci args mdecl let params := firstn (ind_npars mdecl) args in wf_universe Σ ps -> wf_predicate mdecl idecl p -> - isWfArity Σ Γ (it_mkProd_or_LetIn (case_predicate_context ci mdecl idecl p) (tSort ps)). + isWfArity Σ Γ (it_mkProd_or_LetIn (case_predicate_context ci mdecl idecl p) (tSort ps)). Proof. intros wfΣ isdecl X params wfps wfp. split. @@ -3343,7 +3343,7 @@ Proof. Qed. (* -Lemma leb_elim_prop_sort shapes f n cs : +Lemma leb_elim_prop_sort shapes f n cs : allowed_eliminations_subset f (elim_sort_prop_ind shapes) -> nth_error shapes n = Some cs -> allowed_eliminations_subset f (if is_propositional cs.(cdecl_sort) then IntoAny else IntoPropSProp). @@ -3378,7 +3378,7 @@ Proof. Qed. -(* +(* Lemma idecl_binder_ind_binder {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind idecl mdecl p} : declared_inductive Σ ind mdecl idecl -> idecl_binder idecl = ind_binder ind idecl p. @@ -3410,17 +3410,17 @@ Proof. rewrite expand_lets_lift. now rewrite -Nat.add_comm -/(expand_lets_k Γ (context_assumptions Δ) (expand_lets Δ t)). Qed. - -Lemma All2_fold_context_k P (f g : nat -> term -> term) ctx ctx' : + +Lemma All2_fold_context_k P (f g : nat -> term -> term) ctx ctx' : All2_fold (fun Γ Γ' d d' => P (map_decl (f #|Γ|) d) (map_decl (g #|Γ'|) d')) ctx ctx' -> - All2 P (fold_context_k f ctx) (fold_context_k g ctx'). + All2 P (fold_context_k f ctx) (fold_context_k g ctx'). Proof. induction 1. constructor. rewrite !fold_context_k_snoc0. now constructor. Qed. - -Lemma All2_sym {A B} (P : A -> B -> Type) (ctx : list A) (ctx' : list B) : - All2 P ctx ctx' -> + +Lemma All2_sym {A B} (P : A -> B -> Type) (ctx : list A) (ctx' : list B) : + All2 P ctx ctx' -> All2 (fun x y => P y x) ctx' ctx. Proof. induction 1; constructor; auto. @@ -3435,7 +3435,7 @@ Qed. Lemma arity_spine_to_extended_list {cf} {Σ} {wfΣ : wf Σ} {Γ Δ} T : wf_local Σ (Γ ,,, Δ) -> isType Σ (Γ ,,, Δ) T -> - arity_spine Σ (Γ ,,, Δ) (lift0 #|Δ| (it_mkProd_or_LetIn Δ T)) (to_extended_list Δ) + arity_spine Σ (Γ ,,, Δ) (lift0 #|Δ| (it_mkProd_or_LetIn Δ T)) (to_extended_list Δ) T. Proof. intros hty wf. @@ -3514,9 +3514,9 @@ Proof. Qed. Lemma typing_spine_to_extended_list_k_app {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} {T s T'} : - isType Σ (Γ ,,, Δ) T -> + isType Σ (Γ ,,, Δ) T -> typing_spine Σ (Γ ,,, Δ ,,, Δ') (lift0 #|Δ'| T) s T' -> - typing_spine Σ (Γ ,,, Δ ,,, Δ') (lift0 (#|Δ| + #|Δ'|) (it_mkProd_or_LetIn Δ T)) + typing_spine Σ (Γ ,,, Δ ,,, Δ') (lift0 (#|Δ| + #|Δ'|) (it_mkProd_or_LetIn Δ T)) (to_extended_list_k Δ #|Δ'| ++ s) T'. Proof. intros isty sp. @@ -3556,17 +3556,17 @@ Proof. now eapply isType_it_mkProd_or_LetIn. Qed. -Lemma subst_let_expand_lift s Γ n T : +Lemma subst_let_expand_lift s Γ n T : #|s| = context_assumptions Γ -> subst_let_expand (map (lift0 n) s) (lift_context n 0 Γ) (lift n #|Γ| T) = lift0 n (subst_let_expand s Γ T). Proof. intros hs. rewrite /subst_let_expand -(Nat.add_0_r #|Γ|) expand_lets_lift /=. - now rewrite distr_lift_subst hs Nat.add_0_r. + now rewrite distr_lift_subst hs Nat.add_0_r. Qed. -Lemma subst_let_expand_closed_ctx_lift s Γ n T : +Lemma subst_let_expand_closed_ctx_lift s Γ n T : #|s| = context_assumptions Γ -> closed_ctx Γ -> subst_let_expand (map (lift0 n) s) Γ (lift n #|Γ| T) = @@ -3586,7 +3586,7 @@ Lemma wf_case_predicate_context {cf : checker_flags} {Σ : global_env_ext} {wfΣ wf_local Σ (Γ ,,, predctx). Proof. intros isdecl Hc wfp predctx. - epose proof (WfArity_build_case_predicate_type wfΣ isdecl Hc + epose proof (WfArity_build_case_predicate_type wfΣ isdecl Hc (PCUICWfUniverses.wf_universe_type1 Σ) wfp). destruct X. eapply isType_it_mkProd_or_LetIn_inv in i; tea. @@ -3595,9 +3595,9 @@ Qed. Lemma wf_pre_case_branch_context_gen {ci mdecl idecl cdecl} {p} {br} : wf_predicate mdecl idecl p -> - wf_branch cdecl br -> + wf_branch cdecl br -> All2 (fun (x : binder_annot name) (y : context_decl) => eq_binder_annot x (decl_name y)) - (forget_types (bcontext br)) + (forget_types (bcontext br)) (pre_case_branch_context_gen ci mdecl cdecl (pparams p) (puinst p)). Proof. move=> [] hlen hp /Forall2_All2 a. @@ -3617,7 +3617,7 @@ Lemma case_predicate_context_alpha {cf : checker_flags} {Σ : global_env_ext} {w consistent_instance_ext Σ (ind_universes mdecl) p.(puinst) -> let parctx := subst_instance (puinst p) mdecl.(ind_params) in spine_subst Σ Γ p.(pparams) (List.rev p.(pparams)) (smash_context [] parctx) -> - All2 (fun x y => eq_binder_annot x y.(decl_name)) + All2 (fun x y => eq_binder_annot x y.(decl_name)) (forget_types (pcontext p)) (idecl_binder idecl :: ind_indices idecl) -> eq_context_upto_names (case_predicate_context' ind mdecl idecl p) @@ -3678,7 +3678,7 @@ Proof. rewrite /inst_case_context. apply All2_eq_binder_subst_context, All2_eq_binder_subst_instance. eapply All2_map_left, All2_impl; tea. intros x y []; auto. } - { apply alpha_eq_subst_context, alpha_eq_subst_instance. + { apply alpha_eq_subst_context, alpha_eq_subst_instance. now symmetry. } Qed. @@ -3701,7 +3701,7 @@ Proof. eapply All2_eq_binder_subst_context_inst. now eapply All2_eq_binder_subst_context. rewrite /pre_case_branch_context_gen /inst_case_context /cstr_branch_context. - eapply alpha_eq_subst_context. + eapply alpha_eq_subst_context. rewrite subst_instance_expand_lets_ctx subst_instance_subst_context. now rewrite (instantiate_inds decli cu) //. Qed. @@ -3715,15 +3715,15 @@ Lemma wf_case_branch_type {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ;;; Γ ,,, predctx |- p.(preturn) : tSort ps -> let ptm := it_mkLambda_or_LetIn predctx p.(preturn) in eq_context_upto_names p.(pcontext) (ind_predicate_context ci.(ci_ind) mdecl idecl) -> - forall i cdecl br, + forall i cdecl br, declared_constructor Σ (ci.(ci_ind), i) mdecl idecl cdecl -> wf_branch cdecl br -> let cstr_br_ctx := case_branch_context_nopars ci mdecl p.(puinst) cdecl in let brctx' := map2 set_binder_name (forget_types (bcontext br)) cstr_br_ctx in let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in - [× wf_branch cdecl br, + [× wf_branch cdecl br, (* The branch context before substitution of parameters *) - wf_local Σ (Γ ,,, (ind_params mdecl)@[puinst p] ,,, cstr_br_ctx), + wf_local Σ (Γ ,,, (ind_params mdecl)@[puinst p] ,,, cstr_br_ctx), wf_local Σ (Γ ,,, (ind_params mdecl)@[puinst p] ,,, brctx'), wf_local Σ (Γ ,,, brctxty.1) & Σ ;;; Γ ,,, brctxty.1 |- brctxty.2 : tSort ps]. @@ -3783,7 +3783,7 @@ Proof. eapply wf_local_expand_lets => //. rewrite subst_instance_subst_context. rewrite (instantiate_inds nth cu) //. } - split => //. + split => //. { eapply wf_set_binder_name => //. eapply All2_eq_binder_subst_context. eapply All2_eq_binder_subst_instance. @@ -3825,7 +3825,7 @@ Proof. 2:constructor. rewrite /bc. *eapply subslet_eq_context_alpha. - { instantiate (1 := smash_context [] + { instantiate (1 := smash_context [] (lift_context #|case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl| 0 (case_predicate_context' ci mdecl idecl p))). apply alpha_eq_smash_context, alpha_eq_lift_context. @@ -3888,7 +3888,7 @@ Proof. eapply spine_subst_weaken in sp. 2:eapply wfΓ. all:tea. rewrite app_context_assoc in sp. rewrite Nat.add_comm in sp; fold indices in sp. - eapply spine_subst_expand_lets in sp. + eapply spine_subst_expand_lets in sp. rewrite subst_context_length subst_instance_length in sp. eapply spine_subst_subst in sp; tea. 2:exact sppars. @@ -4055,7 +4055,7 @@ Proof. rewrite -(Nat.add_0_r #|ind_indices idecl|) -to_extended_list_map_lift. relativize (to_extended_list (ind_indices idecl)). erewrite map_subst_let_expand_k_to_extended_list_lift. - 3:{ rewrite /expand_lets_ctx /expand_lets_k_ctx + 3:{ rewrite /expand_lets_ctx /expand_lets_k_ctx !to_extended_list_k_lift_context !to_extended_list_k_subst PCUICLiftSubst.map_subst_instance_to_extended_list_k @@ -4083,7 +4083,7 @@ Lemma wf_case_branch_type' {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ;;; Γ ,,, predctx |- p.(preturn) : tSort ps -> let ptm := it_mkLambda_or_LetIn predctx p.(preturn) in eq_context_upto_names p.(pcontext) (ind_predicate_context ci.(ci_ind) mdecl idecl) -> - forall i cdecl br, + forall i cdecl br, declared_constructor Σ (ci.(ci_ind), i) mdecl idecl cdecl -> wf_branch cdecl br -> let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in @@ -4185,7 +4185,7 @@ Proof. 2:constructor. rewrite /bc. * eapply subslet_eq_context_alpha. - { instantiate (1 := smash_context [] + { instantiate (1 := smash_context [] (lift_context #|case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl| 0 (case_predicate_context' ci mdecl idecl p))). apply alpha_eq_smash_context, alpha_eq_lift_context. @@ -4248,7 +4248,7 @@ Proof. eapply spine_subst_weaken in sp. 2:eapply wfΓ. all:tea. rewrite app_context_assoc in sp. rewrite Nat.add_comm in sp; fold indices in sp. - eapply spine_subst_expand_lets in sp. + eapply spine_subst_expand_lets in sp. rewrite subst_context_length subst_instance_length in sp. eapply spine_subst_subst in sp; tea. 2:exact sppars. @@ -4415,7 +4415,7 @@ Proof. rewrite -(Nat.add_0_r #|ind_indices idecl|) -to_extended_list_map_lift. relativize (to_extended_list (ind_indices idecl)). erewrite map_subst_let_expand_k_to_extended_list_lift. - 3:{ rewrite /expand_lets_ctx /expand_lets_k_ctx + 3:{ rewrite /expand_lets_ctx /expand_lets_k_ctx !to_extended_list_k_lift_context !to_extended_list_k_subst PCUICLiftSubst.map_subst_instance_to_extended_list_k @@ -4444,10 +4444,10 @@ Lemma wf_case_branches_types {cf : checker_flags} {Σ : global_env_ext} {wfΣ : let ptm := it_mkLambda_or_LetIn predctx p.(preturn) in wf_branches idecl brs -> eq_context_upto_names p.(pcontext) (ind_predicate_context ci.(ci_ind) mdecl idecl) -> - All2i (fun i cdecl br => + All2i (fun i cdecl br => let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in wf_local Σ (Γ ,,, brctxty.1) × - Σ ;;; Γ ,,, brctxty.1 |- brctxty.2 : tSort ps) + Σ ;;; Γ ,,, brctxty.1 |- brctxty.2 : tSort ps) 0 (ind_ctors idecl) brs. Proof. intros isdecl Hc wfp bc Hp ptm wfbrs conv. @@ -4475,11 +4475,11 @@ Lemma wf_case_branches_types' {cf : checker_flags} {Σ : global_env_ext} {wfΣ : let brctx' := map2 set_binder_name (forget_types (bcontext br)) cstr_br_ctx in let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in [× wf_branch cdecl br, (* The branch context before substitution of parameters *) - wf_local Σ (Γ ,,, (ind_params mdecl)@[puinst p] ,,, cstr_br_ctx), - wf_local Σ (Γ ,,, (ind_params mdecl)@[puinst p] ,,, brctx'), + wf_local Σ (Γ ,,, (ind_params mdecl)@[puinst p] ,,, cstr_br_ctx), + wf_local Σ (Γ ,,, (ind_params mdecl)@[puinst p] ,,, brctx'), (* The branch context after substitution of parameters *) wf_local Σ (Γ ,,, brctxty.1) & - Σ ;;; Γ ,,, brctxty.1 |- brctxty.2 : tSort ps]) + Σ ;;; Γ ,,, brctxty.1 |- brctxty.2 : tSort ps]) 0 (ind_ctors idecl) brs. Proof. intros isdecl Hc wfp bc Hp ptm wfbrs conv. diff --git a/pcuic/theories/PCUICInductives.v b/pcuic/theories/PCUICInductives.v index c9a42cd14..60716b1f9 100644 --- a/pcuic/theories/PCUICInductives.v +++ b/pcuic/theories/PCUICInductives.v @@ -1,11 +1,11 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICInduction - PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICWeakeningEnvConv PCUICWeakeningEnvTyp + PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICWeakeningConv PCUICWeakeningTyp PCUICSigmaCalculus PCUICInstDef PCUICInstConv PCUICContextSubst PCUICRenameDef PCUICRenameConv PCUICRenameTyp - PCUICSubstitution PCUICOnFreeVars PCUICClosed PCUICClosedConv PCUICClosedTyp + PCUICSubstitution PCUICOnFreeVars PCUICClosed PCUICClosedConv PCUICClosedTyp PCUICCumulativity PCUICGeneration PCUICReduction PCUICWellScopedCumulativity PCUICEquality PCUICConfluence PCUICParallelReductionConfluence PCUICContextConversion PCUICUnivSubstitutionConv @@ -1035,7 +1035,7 @@ Proof. (smash_context [] (cstr_args c))) eqn:eqargs. apply (f_equal (@length _)) in eqargs. autorewrite with len in eqargs. - rewrite skipn_length in eqargs. + rewrite skipn_length in eqargs. autorewrite with len in eqargs. simpl in eqargs. lia. rewrite subst_context_snoc lift_context_snoc subst_context_snoc. simpl. @@ -1255,7 +1255,7 @@ Proof. constructor. reflexivity. rewrite -subst_instance_it_mkProd_or_LetIn. pose proof (onArity oib). rewrite -(oib.(ind_arity_eq)). - apply infer_typing_sort_impl with id X1. + apply infer_typing_sort_impl with id X1. eapply (weaken_ctx (Γ:=[])); auto. } intros wf. generalize (weakening_wf_local (Γ'':=[_]) wf X1). @@ -1991,7 +1991,7 @@ Proof. epose proof (@closed_red_red_subst _ _ _ Δ [vdef na b ty] (skipn (context_assumptions Γ - n) (smash_context [] Γ)) _ _ _). rewrite subst_empty lift0_id lift0_context. - rewrite !skipn_length in X; autorewrite with len. + rewrite !skipn_length in X; autorewrite with len. autorewrite with len in X. simpl in X. assert(context_assumptions Γ - (context_assumptions Γ - n) = n) by lia. rewrite H1 in X. rewrite skipn_subst_context. diff --git a/pcuic/theories/PCUICInversion.v b/pcuic/theories/PCUICInversion.v index 1a5fbd28f..0fadb2214 100644 --- a/pcuic/theories/PCUICInversion.v +++ b/pcuic/theories/PCUICInversion.v @@ -37,7 +37,7 @@ Section Inversion. destruct ih as [? ?] end. - Lemma into_ws_cumul {Γ t T U s} : + Lemma into_ws_cumul {Γ t T U s} : Σ ;;; Γ |- t : T -> Σ ;;; Γ |- U : tSort s -> Σ ;;; Γ |- T <= U -> @@ -51,7 +51,7 @@ Section Inversion. eapply PCUICOnFreeVars.closedn_on_free_vars in X0; tea. Qed. - Lemma typing_closed_ctx Γ t T : + Lemma typing_closed_ctx Γ t T : Σ ;;; Γ |- t : T -> is_closed_context Γ. Proof using wfΣ. @@ -59,7 +59,7 @@ Section Inversion. Qed. Hint Immediate typing_closed_ctx : fvs. - Lemma typing_ws_cumul_pb le Γ t T : + Lemma typing_ws_cumul_pb le Γ t T : Σ ;;; Γ |- t : T -> Σ ;;; Γ ⊢ T ≤[le] T. Proof using wfΣ. @@ -82,7 +82,7 @@ Section Inversion. repeat insum ; repeat intimes ; [ try first [ eassumption | reflexivity ] .. - | try etransitivity ; try eassumption; + | try etransitivity ; try eassumption; try eauto with pcuic; try solve [eapply into_ws_cumul; tea] ] ]. @@ -100,7 +100,7 @@ Section Inversion. rewrite -on_free_vars_ctx_on_ctx_free_vars in isc. rewrite <- (addnP0) in isc. eapply nth_error_on_free_vars_ctx in isc; tea. - 2:{ rewrite /shiftnP orb_false_r. eapply Nat.ltb_lt. + 2:{ rewrite /shiftnP orb_false_r. eapply Nat.ltb_lt. eapply nth_error_Some_length in hnth. lia. } now move/andP: isc=> [] _ /on_free_vars_lift0 /=. Qed. @@ -196,7 +196,7 @@ Section Inversion. intros Γ u v T h. invtac h. Qed. - Lemma inversion_App_size : + Lemma inversion_App_size : forall {Γ u v T} (H : Σ ;;; Γ |- tApp u v : T), ∑ na A B s (H1 : Σ ;;; Γ |- u : tProd na A B) (H2 : Σ ;;; Γ |- v : A) (H3 : Σ ;;; Γ |- tProd na A B : tSort s), @@ -274,7 +274,7 @@ Section Inversion. Lemma inversion_Case : forall {Γ ci p c brs T}, Σ ;;; Γ |- tCase ci p c brs : T -> - ∑ mdecl idecl (isdecl : declared_inductive Σ.1 ci.(ci_ind) mdecl idecl) indices, + ∑ mdecl idecl (isdecl : declared_inductive Σ.1 ci.(ci_ind) mdecl idecl) indices, let predctx := case_predicate_context ci.(ci_ind) mdecl idecl p in let ptm := it_mkLambda_or_LetIn predctx p.(preturn) in case_inversion_data Γ ci p c brs mdecl idecl indices × @@ -282,7 +282,7 @@ Section Inversion. Proof using wfΣ. intros Γ ci p c brs T h. dependent induction h. - { remember c0; remember c1. destruct c0, c1. repeat insum; repeat intimes; try eapply case_inv ; + { remember c0; remember c1. destruct c0, c1. repeat insum; repeat intimes; try eapply case_inv ; [ try first [ eassumption | reflexivity ].. | try eapply typing_ws_cumul_pb; econstructor; eauto ]. } repeat outsum; repeat outtimes; repeat insum; repeat intimes ; tea; [ try first @@ -337,12 +337,12 @@ Section Inversion. Lemma inversion_Prim : forall {Γ p T}, - Σ ;;; Γ |- tPrim p : T -> - ∑ prim_ty cdecl, + Σ ;;; Γ |- tPrim p : T -> + ∑ prim_ty cdecl, [× wf_local Σ Γ, primitive_constant Σ (prim_val_tag p) = Some prim_ty, declared_constant Σ prim_ty cdecl, - primitive_invariants cdecl & + primitive_invariants cdecl & Σ ;;; Γ ⊢ tConst prim_ty [] ≤ T]. Proof. intros Γ p T h. depind h. @@ -350,7 +350,7 @@ Section Inversion. eapply ws_cumul_pb_refl; fvs. - destruct IHh1 as [prim_ty [cdecl []]]. exists prim_ty, cdecl. split => //. - transitivity A; tea. eapply cumulSpec_cumulAlgo_curry; tea; fvs. + transitivity A; tea. eapply cumulSpec_cumulAlgo_curry; tea; fvs. Qed. Lemma inversion_it_mkLambda_or_LetIn : diff --git a/pcuic/theories/PCUICNormal.v b/pcuic/theories/PCUICNormal.v index 9416c0e80..fa75c0202 100644 --- a/pcuic/theories/PCUICNormal.v +++ b/pcuic/theories/PCUICNormal.v @@ -3,7 +3,7 @@ From Coq Require Import Bool String List Program BinPos Compare_dec Arith Lia. From MetaCoq.Template Require Import config Universes monad_utils utils BasicAst AstUtils UnivSubst. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICOnOne PCUICCases +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICOnOne PCUICCases PCUICContextReduction PCUICEquality PCUICLiftSubst PCUICTyping PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICReduction PCUICClosedTyp PCUICInduction PCUICRedTypeIrrelevance PCUICOnFreeVars. @@ -48,7 +48,7 @@ Section Normal. | whne_rel_nozeta i : RedFlags.zeta flags = false -> whne Γ (tRel i) - + | whne_lam_nobeta na A b : RedFlags.beta flags = false -> whne Γ (tLambda na A b) @@ -79,14 +79,14 @@ Section Normal. (* Stuck fixpoints are neutrals *) | whne_fixapp mfix idx args rarg arg body : unfold_fix mfix idx = Some (rarg, body) -> - nth_error args rarg = Some arg -> + nth_error args rarg = Some arg -> whne Γ arg -> whne Γ (mkApps (tFix mfix idx) args) - + | whne_fix_nofix defs i : RedFlags.fix_ flags = false -> whne Γ (tFix defs i) - + | whne_case i p c brs : whne Γ c -> whne Γ (tCase i p c brs) @@ -138,7 +138,7 @@ Section Normal. Proof using Type. intros. econstructor. now eapply whne_mkApps. Qed. - + Lemma whne_mkApps_inv : forall Γ t l, negb (isApp t) -> @@ -160,10 +160,10 @@ Section Normal. + rewrite <- mkApps_snoc in x. eapply (f_equal decompose_app) in x; rewrite !decompose_app_mkApps in x; cbn in *; try intuition congruence. - inversion x. subst. + inversion x. subst. right. exists mfix, idx, rarg, body, arg. repeat split; eauto. Qed. - + End Normal. Derive Signature for whnf. @@ -177,7 +177,7 @@ Hint Constructors whnf whne : pcuic. Local Ltac inv H := inversion H; subst; clear H. Ltac help' := try repeat match goal with -| [ H0 : _ = mkApps _ _ |- _ ] => +| [ H0 : _ = mkApps _ _ |- _ ] => eapply (f_equal decompose_app) in H0; rewrite !decompose_app_mkApps in H0; cbn in *; intuition congruence | [ H1 : tApp _ _ = mkApps _ ?args |- _ ] => @@ -267,7 +267,7 @@ Lemma whnf_fixapp' {flags} Σ Γ mfix idx narg body v : whnf flags Σ Γ (mkApps (tFix mfix idx) v). Proof. intros E1 H. eapply whnf_fixapp. rewrite E1. eauto. -Qed. +Qed. #[global] Hint Resolve whnf_fixapp' : core. @@ -328,8 +328,8 @@ Proof with eauto using sq with pcuic; try congruence. all: try now (right; intros [H]; depelim H;help). - destruct (RedFlags.zeta flags) eqn:Er. + destruct (option_map decl_body (nth_error Γ n)) as [ [ | ] | ] eqn:E... - * right. intros [H]. depelim H. depelim w. congruence. congruence. all:help. - * right. intros [H]. depelim H. depelim w. congruence. congruence. all:help. + * right. intros [H]. depelim H. depelim w. congruence. congruence. all:help. + * right. intros [H]. depelim H. depelim w. congruence. congruence. all:help. + eauto using sq. - destruct (RedFlags.zeta flags) eqn:Er... destruct (option_map decl_body (nth_error Γ n)) as [ [ | ] | ] eqn:E... @@ -369,11 +369,11 @@ Proof with eauto using sq with pcuic; try congruence. destruct (nth_error_all E2 X Γ) as [_ []]. ++ left. destruct s0... ++ destruct (RedFlags.fix_ flags) eqn:?. - ** right. intros [w]. depelim w. depelim w. all:help. clear IHv. + ** right. intros [w]. depelim w. depelim w. all:help. clear IHv. eapply whne_mkApps_inv in w as []; eauto. - --- depelim w; [|congruence]. help. - eapply (f_equal decompose_app) in x; - rewrite !decompose_app_mkApps in x; cbn in *; try intuition congruence. + --- depelim w; [|congruence]. help. + eapply (f_equal decompose_app) in x; + rewrite !decompose_app_mkApps in x; cbn in *; try intuition congruence. inv x. destruct rarg; inv e0. --- destruct s0 as (? & ? & ? & ? & ? & ? & ? & ? & ?). inv e. rewrite E1 in e0. inv e0. @@ -395,8 +395,8 @@ Proof with eauto using sq with pcuic; try congruence. right. intros [w]. depelim w. depelim w. all:help. clear IHt. eapply whne_mkApps_inv in w as []... -- depelim w. help. - -- destruct s0 as [? [? [? [? [? [? ?]]]]]]. congruence. - + right. intros [w]. eapply n. constructor. now eapply whnf_mkApps_inv. + -- destruct s0 as [? [? [? [? [? [? ?]]]]]]. congruence. + + right. intros [w]. eapply n. constructor. now eapply whnf_mkApps_inv. - destruct (IHt Γ) as [_ []]. + left. destruct s as [w]. constructor. now eapply whne_mkApps. + destruct t. @@ -406,7 +406,7 @@ Proof with eauto using sq with pcuic; try congruence. ++ destruct (nth_error_all E2 X Γ) as [_ []]. ** left. destruct s. constructor. eauto. ** destruct (RedFlags.fix_ flags) eqn:?. - --- right. intros ?. depelim H1. depelim X0. all:help. clear IHv. + --- right. intros ?. depelim H1. depelim X0. all:help. clear IHv. eapply whne_mkApps_inv in X0 as []... destruct s as (? & ? & ? & ? & ? & ? & ? & ? & ?). inv e. rewrite E1 in e0. inv e0. @@ -431,8 +431,8 @@ Proof with eauto using sq with pcuic; try congruence. right. intros [w]. depelim w. congruence. congruence. help. + right. intros [w]. depelim w. congruence. congruence. help. + right. intros [w]. depelim w. congruence. congruence. help. - - left. constructor. eapply whnf_indapp with (v := []). - - left. constructor. eapply whnf_cstrapp with (v := []). + - left. constructor. eapply whnf_indapp with (v := []). + - left. constructor. eapply whnf_cstrapp with (v := []). - destruct (RedFlags.iota flags) eqn:Eq... destruct (IHt Γ) as [_ []]. + left. destruct s... @@ -475,7 +475,7 @@ Proof. + eapply IHv in X as (? & ? & ?). subst. exists (x0 ++ [x]). rewrite mkApps_snoc. split; eauto. apply OnOne2_app_r. assumption. - + exists (v ++ [N2]). rewrite mkApps_snoc. split; eauto. + + exists (v ++ [N2]). rewrite mkApps_snoc. split; eauto. eapply OnOne2_app. econstructor. eauto. Qed. @@ -491,7 +491,7 @@ Proof. + eapply IHv in X as (? & ? & ?). subst. exists (x0 ++ [x]). rewrite mkApps_snoc. split; eauto. apply OnOne2_app_r. assumption. - + exists (v ++ [N2]). rewrite mkApps_snoc. split; eauto. + + exists (v ++ [N2]). rewrite mkApps_snoc. split; eauto. eapply OnOne2_app. econstructor. eauto. Qed. @@ -509,7 +509,7 @@ Proof. rewrite app_length in nth. lia. Qed. - + Lemma red1_mkApps_tFix_inv Σ Γ mfix id v t' : match unfold_fix mfix id with | Some (rarg, body) => is_constructor rarg v = false @@ -539,7 +539,7 @@ Proof. * destruct unfold_fix as [(?&?)|]; [|easy]. now eapply is_constructor_app_false. + left. left. exists (v ++ [N2]). split. - now rewrite mkApps_snoc. + now rewrite mkApps_snoc. eapply OnOne2_app. econstructor. eauto. Qed. @@ -559,7 +559,7 @@ Proof. * subst. left. right. exists x0. split. now rewrite mkApps_snoc. eauto. * subst. right. exists x0. split. now rewrite mkApps_snoc. eauto. + left. left. exists (v ++ [N2]). split. - now rewrite mkApps_snoc. + now rewrite mkApps_snoc. eapply OnOne2_app. econstructor. eauto. Qed. @@ -580,7 +580,7 @@ Proof. depelim wh. solve_discr. Qed. - + Lemma whnf_mkApps_tSort_inv f Σ Γ s args : whnf f Σ Γ (mkApps (tSort s) args) -> args = []. Proof. @@ -639,7 +639,7 @@ Context (Σ : global_env). Context (Γ : context). Context (P : term -> term -> Type). -Lemma whne_red1_ind +Lemma whne_red1_ind (Hrel : forall i body, RedFlags.zeta flags = false -> option_map decl_body (nth_error Γ i) = Some (Some body) -> @@ -740,8 +740,8 @@ Lemma whne_red1_ind P c c' -> P (tCase i p c brs) (tCase i p c' brs)) (Hcase_branch : forall i p c brs brs', - whne flags Σ Γ c -> - OnOne2 (fun br br' => + whne flags Σ Γ c -> + OnOne2 (fun br br' => let ctx := inst_case_branch_context p br in (on_Trel_eq (red1 Σ (Γ ,,, ctx)) bbody bcontext br br')%type) brs brs' -> @@ -893,7 +893,7 @@ Lemma whne_pres Σ Γ t t' : Proof. induction 1 using red_rect_n1; eauto using whne_pres1. Qed. - + Lemma whnf_pres1 Σ Γ t t' : red1 Σ Γ t t' -> whnf RedFlags.default Σ Γ t -> @@ -987,8 +987,8 @@ Inductive whnf_red Σ Γ : term -> term -> Type := All2 (fun br br' => red Σ (Γ ,,, inst_case_branch_context motive br) br.(bbody) br'.(bbody) × bcontext br = bcontext br') brs brs' -> - whnf_red Σ Γ (tCase ci motive discr brs) - (tCase ci {| pparams := motivepars; + whnf_red Σ Γ (tCase ci motive discr brs) + (tCase ci {| pparams := motivepars; puinst := motive.(puinst); pcontext := motive.(pcontext); preturn := motiveret |} discr' brs') @@ -1022,8 +1022,8 @@ Derive Signature for whnf_red. #[global] Hint Constructors whnf_red : pcuic. -Lemma All3_impl {A B C} (P Q : A -> B -> C -> Type) {l l' l''} - (a : All3 P l l' l'') : +Lemma All3_impl {A B C} (P Q : A -> B -> C -> Type) {l l' l''} + (a : All3 P l l' l'') : (forall x y z, P x y z -> Q x y z) -> All3 Q l l' l''. Proof. @@ -1164,11 +1164,11 @@ Ltac inv_on_free_vars := match goal with | [ H : is_true (on_free_vars_decl _ _) |- _ ] => progress cbn in H | [ H : is_true (on_free_vars_decl _ (vdef _ _ _)) |- _ ] => unfold on_free_vars_decl, test_decl in H - | [ H : is_true (_ && _) |- _ ] => + | [ H : is_true (_ && _) |- _ ] => move/andP: H => []; intros - | [ H : is_true (on_free_vars ?P ?t) |- _ ] => + | [ H : is_true (on_free_vars ?P ?t) |- _ ] => progress (cbn in H || rewrite on_free_vars_mkApps in H); - (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || + (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || eapply forallb_All in H); intros | [ H : is_true (test_def (on_free_vars ?P) ?Q ?x) |- _ ] => move/andP: H => []; rewrite ?shiftnP_xpredT; intros @@ -1178,7 +1178,7 @@ Ltac inv_on_free_vars := Require Import PCUICWellScopedCumulativity PCUICOnFreeVars PCUICConfluence PCUICSR PCUICConversion PCUICSubstitution. -Lemma red_ctx_rel_subst {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} P Γ Γ' s s' Δ : +Lemma red_ctx_rel_subst {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} P Γ Γ' s s' Δ : All2 (red Σ Γ) s s' -> All (on_free_vars (shiftnP #|Γ| P)) s -> untyped_subslet Γ s Γ' -> @@ -1189,9 +1189,9 @@ Proof. induction Δ; cbn. * rewrite !subst_context_nil. constructor. * move: onctx => /=. rewrite on_free_vars_ctx_snoc => /andP[] onctx ona. - rewrite !subst_context_snoc !Nat.add_0_r. + rewrite !subst_context_snoc !Nat.add_0_r. constructor; eauto. - now apply IHΔ. + now apply IHΔ. destruct a as [na [b|] ty]; constructor; cbn. relativize #|Δ|. eapply red_red; tea. 4:auto. erewrite on_free_vars_ctx_on_ctx_free_vars => //; tea. @@ -1210,7 +1210,7 @@ Proof. solve_all. rewrite !app_context_length Nat.add_assoc -shiftnP_add addnP_shiftnP //. Qed. -Definition fake_params n : context := +Definition fake_params n : context := unfold n (fun x => {| decl_name := {| binder_name := nAnon; binder_relevance := Relevant |}; decl_body := None; decl_type := tSort Universe.type0 |}). @@ -1258,7 +1258,7 @@ Lemma br_fvs_pres {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} Γ mot All (br_fvs Γ motive) brs -> All2 (fun br br' : branch term => - red Σ (Γ,,, inst_case_branch_context motive br) + red Σ (Γ,,, inst_case_branch_context motive br) (bbody br) (bbody br') * (bcontext br = bcontext br')) brs brs' -> All (br_fvs Γ motive) brs'. Proof. @@ -1272,7 +1272,7 @@ Proof. eapply on_free_vars_ctx_inst_case_context; trea. solve_all. Qed. -Lemma whnf_red_trans {cf:checker_flags} {Σ : global_env_ext} Γ x y z : wf Σ -> +Lemma whnf_red_trans {cf:checker_flags} {Σ : global_env_ext} Γ x y z : wf Σ -> is_closed_context Γ -> is_open_term Γ x -> whnf_red Σ Γ x y -> @@ -1307,7 +1307,7 @@ Proof. have clp: on_ctx_free_vars (closedP #|Γ,,, inst_case_predicate_context motive| xpredT) (Γ,,, inst_case_predicate_context motive). { rewrite closedP_shiftnP_eq on_free_vars_ctx_on_ctx_free_vars. - rewrite on_free_vars_ctx_app onΓ /=. + rewrite on_free_vars_ctx_app onΓ /=. eapply on_free_vars_ctx_inst_case_context => //. rewrite test_context_k_closed_on_free_vars_ctx //. } eapply red_red_ctx. 5:tea. all:eauto; revgoals. @@ -1333,18 +1333,18 @@ Proof. * rewrite closedP_shiftnP_eq. relativize #|Γ ,,, _|; [erewrite on_free_vars_ctx_on_ctx_free_vars|]. 2:len. - rewrite on_free_vars_ctx_app onΓ /=. + rewrite on_free_vars_ctx_app onΓ /=. eapply on_free_vars_ctx_inst_case_context => //. cbn. eapply red_terms_on_free_vars; tea. - rewrite test_context_k_closed_on_free_vars_ctx -(All2_length a) //. + rewrite test_context_k_closed_on_free_vars_ctx -(All2_length a) //. + eapply forallb_All in p3. epose proof (br_fvs_pres _ _ _ _ onΓ p p3 a0). - eapply (All2_impl (P:=fun br br' => br_fvs Γ motive br × + eapply (All2_impl (P:=fun br br' => br_fvs Γ motive br × red Σ (Γ,,, inst_case_branch_context motive br) (bbody br) (bbody br') * (bcontext br = bcontext br'))). 2:intuition. - eapply All2_trans with brs'. + eapply All2_trans with brs'. { clear -wf p. intros br br' br''. intuition auto. 2:congruence. etransitivity; tea. unfold inst_case_branch_context in *. now rewrite -b1 in a2. } @@ -1356,7 +1356,7 @@ Proof. eapply red_red_ctx. 5:tea. all:eauto; revgoals. apply red_context_app_right; eauto. * rewrite closedP_shiftnP_eq on_free_vars_ctx_on_ctx_free_vars. - rewrite on_free_vars_ctx_app onΓ /=. + rewrite on_free_vars_ctx_app onΓ /=. eapply on_free_vars_ctx_inst_case_context => //. * apply red_context_refl. * rewrite /inst_case_branch_context /=. @@ -1378,12 +1378,12 @@ Proof. * rewrite shiftnP_add. relativize (#|_| + _); [erewrite on_free_vars_ctx_on_ctx_free_vars|]. 2:len. - rewrite on_free_vars_ctx_app onΓ /=. + rewrite on_free_vars_ctx_app onΓ /=. eapply on_free_vars_ctx_inst_case_context => //. * rewrite shiftnP_add. relativize (#|_| + _); [erewrite on_free_vars_ctx_on_ctx_free_vars|]. 2:len. - rewrite on_free_vars_ctx_app onΓ /=. + rewrite on_free_vars_ctx_app onΓ /=. eapply on_free_vars_ctx_inst_case_context => //. eapply red_terms_on_free_vars; tea. now rewrite -(All2_length a). diff --git a/pcuic/theories/PCUICParallelReduction.v b/pcuic/theories/PCUICParallelReduction.v index 1dd1a116b..f52a76a74 100644 --- a/pcuic/theories/PCUICParallelReduction.v +++ b/pcuic/theories/PCUICParallelReduction.v @@ -4,9 +4,9 @@ From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICUtils PCUICOnOne PCUICAst PCUICAstUtils PCUICTactics PCUICDepth PCUICCases PCUICLiftSubst PCUICUnivSubst PCUICReduction PCUICTyping PCUICSigmaCalculus PCUICWeakeningEnvConv PCUICInduction - PCUICRenameDef PCUICRenameConv PCUICInstDef PCUICInstConv PCUICOnFreeVars + PCUICRenameDef PCUICRenameConv PCUICInstDef PCUICInstConv PCUICOnFreeVars PCUICWeakeningConv PCUICWeakeningTyp PCUICSubstitution. - + Require Import ssreflect ssrbool. From Equations Require Import Equations. @@ -14,8 +14,8 @@ Set Default Proof Using "Type*". Local Set Keyed Unification. -Ltac simplify_IH_hyps := - repeat match goal with +Ltac simplify_IH_hyps := + repeat match goal with [ H : _ |- _ ] => eqns_specialize_eqs H end. @@ -39,7 +39,7 @@ Proof. apply aux; apply r. apply IHAll2. Defined. -Lemma All2_branch_prop {P Q : context -> context -> branch term -> branch term -> Type} +Lemma All2_branch_prop {P Q : context -> context -> branch term -> branch term -> Type} {par par'} {l l' : list (branch term)} : All2 (P par par') l l' -> (forall x y, P par par' x y -> Q par par' x y) -> @@ -80,7 +80,7 @@ Proof. apply aux. destruct r. apply p. split. apply aux. apply r. apply r. apply IHAll2. Defined. -(** Specialization of All2_fold to on_decls / All_decls. +(** Specialization of All2_fold to on_decls / All_decls. It compares contexts up to `P` and no alpha-equivalence. *) Notation on_decls_over P Γ Γ' := (fun Δ Δ' => P (Γ ,,, Δ) (Γ' ,,, Δ')). Notation on_contexts_over P Γ Γ' := (All2_fold (on_decls (on_decls_over P Γ Γ'))). @@ -89,7 +89,7 @@ Notation on_contexts_length := All2_fold_length. Section All2_fold. - (** Do not change this definition as it is used in a raw fixpoint so should preserve + (** Do not change this definition as it is used in a raw fixpoint so should preserve the guard condition. *) Lemma on_contexts_impl {P Q : context -> context -> term -> term -> Type} {par par'} : on_contexts P par par' -> @@ -154,7 +154,7 @@ Section All2_fold. apply: All2_fold_app_inv => //. apply All2_fold_length in a. len in a. Qed. - + Lemma nth_error_pred1_ctx {P} {Γ Δ} i body' : on_contexts P Γ Δ -> option_map decl_body (nth_error Δ i) = Some (Some body') -> @@ -198,9 +198,9 @@ Section All2_fold. intros. eapply on_contexts_app_inv in X; intuition auto. Qed. - Lemma on_contexts_mapi P Γ Δ f g : + Lemma on_contexts_mapi P Γ Δ f g : All2_fold (on_decls - (fun Γ Γ' t t' => + (fun Γ Γ' t t' => P (mapi_context f Γ) (mapi_context g Γ') (f #|Γ| t) (g #|Γ'| t'))) Γ Δ -> on_contexts P (mapi_context f Γ) (mapi_context g Δ). Proof. @@ -208,16 +208,16 @@ Section All2_fold. depelim p; constructor; auto. Qed. - Lemma on_contexts_mapi_inv P Γ Δ f g : + Lemma on_contexts_mapi_inv P Γ Δ f g : on_contexts P (mapi_context f Γ) (mapi_context g Δ) -> - on_contexts (fun Γ Γ' t t' => + on_contexts (fun Γ Γ' t t' => P (mapi_context f Γ) (mapi_context g Γ') (f #|Γ| t) (g #|Γ'| t')) Γ Δ. Proof. induction Γ in Δ |- *; destruct Δ; intros h; depelim h. - constructor. - constructor; auto. destruct a as [na [b|] ty], c as [na' [b'|] ty']; cbn in * => //; - depelim a0; constructor; auto. + depelim a0; constructor; auto. Qed. End All2_fold. @@ -266,15 +266,15 @@ Section ParallelReduction. | pred_iota ci c u args0 args1 p0 params' brs0 brs1 br : pred1_ctx Γ Γ' -> All2 (pred1 Γ Γ') args0 args1 -> - nth_error brs1 c = Some br -> + nth_error brs1 c = Some br -> #|args1| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat -> All2 (pred1 Γ Γ') p0.(pparams) params' -> - All2 (fun br br' => - pred1_ctx_over Γ Γ' (inst_case_branch_context p0 br) + All2 (fun br br' => + pred1_ctx_over Γ Γ' (inst_case_branch_context p0 br) (inst_case_context params' p0.(puinst) br'.(bcontext)) × - on_Trel_eq (pred1 (Γ ,,, inst_case_branch_context p0 br) + on_Trel_eq (pred1 (Γ ,,, inst_case_branch_context p0 br) (Γ' ,,, inst_case_context params' (puinst p0) (bcontext br))) bbody bcontext br br') brs0 brs1 -> - pred1 Γ Γ' + pred1 Γ Γ' (tCase ci p0 (mkApps (tConstruct ci.(ci_ind) c u) args0) brs0) (iota_red ci.(ci_npar) (set_pparams p0 params') args1 br) @@ -303,7 +303,7 @@ Section ParallelReduction. pred1_ctx_over Γ Γ' (PCUICCases.inst_case_predicate_context p0) (PCUICCases.inst_case_predicate_context p1) -> pred1 (Γ ,,, PCUICCases.inst_case_predicate_context p0) (Γ' ,,, PCUICCases.inst_case_predicate_context p1) p0.(preturn) p1.(preturn) -> - All2 (fun br br' => + All2 (fun br br' => pred1_ctx_over Γ Γ' (inst_case_branch_context p0 br) (inst_case_branch_context p1 br') × on_Trel_eq (pred1 (Γ ,,, inst_case_branch_context p0 br) (Γ' ,,, inst_case_branch_context p1 br')) @@ -342,8 +342,8 @@ Section ParallelReduction. pred1 Γ Γ' (tProj p (mkApps (tConstruct p.(proj_ind) 0 u) args0)) arg1 (** Congruences *) - | pred_abs na M M' N N' : - pred1 Γ Γ' M M' -> + | pred_abs na M M' N N' : + pred1 Γ Γ' M M' -> pred1 (Γ ,, vass na M) (Γ' ,, vass na M') N N' -> pred1 Γ Γ' (tLambda na M N) (tLambda na M' N') @@ -362,9 +362,9 @@ Section ParallelReduction. p0.(puinst) = p1.(puinst) -> p0.(pcontext) = p1.(pcontext) -> pred1_ctx_over Γ Γ' (PCUICCases.inst_case_predicate_context p0) (PCUICCases.inst_case_predicate_context p1) -> - pred1 (Γ ,,, inst_case_context p0.(pparams) p0.(puinst) p0.(pcontext)) + pred1 (Γ ,,, inst_case_context p0.(pparams) p0.(puinst) p0.(pcontext)) (Γ' ,,, inst_case_context p1.(pparams) p1.(puinst) p1.(pcontext)) p0.(preturn) p1.(preturn) -> - All2 (fun br br' => + All2 (fun br br' => pred1_ctx_over Γ Γ' (inst_case_branch_context p0 br) (inst_case_branch_context p1 br') × on_Trel_eq (pred1 (Γ ,,, inst_case_branch_context p0 br) (Γ' ,,, inst_case_branch_context p1 br')) @@ -373,7 +373,7 @@ Section ParallelReduction. pred1 Γ Γ' (tCase ci p0 c0 brs0) (tCase ci p1 c1 brs1) | pred_proj_congr p c c' : - pred1 Γ Γ' c c' -> + pred1 Γ Γ' c c' -> pred1 Γ Γ' (tProj p c) (tProj p c') | pred_fix_congr mfix0 mfix1 idx : @@ -391,7 +391,7 @@ Section ParallelReduction. pred1 Γ Γ' (tCoFix mfix0 idx) (tCoFix mfix1 idx) | pred_prod na M0 M1 N0 N1 : - pred1 Γ Γ' M0 M1 -> + pred1 Γ Γ' M0 M1 -> pred1 (Γ ,, vass na M0) (Γ' ,, vass na M1) N0 N1 -> pred1 Γ Γ' (tProd na M0 N0) (tProd na M1 N1) @@ -401,7 +401,7 @@ Section ParallelReduction. | pred_atom_refl t : pred1_ctx Γ Γ' -> - pred_atom t -> + pred_atom t -> pred1 Γ Γ' t t where "'pred1_ctx'" := (All2_fold (on_decls pred1)) @@ -469,13 +469,13 @@ Section ParallelReduction. All2 (P' Γ Γ') args0 args1 -> All2 (P' Γ Γ') p0.(pparams) pparams1 -> All2 (fun br br' => - Pctxover Γ Γ' (inst_case_branch_context p0 br) + Pctxover Γ Γ' (inst_case_branch_context p0 br) (inst_case_context pparams1 p0.(puinst) br'.(bcontext)) × - on_Trel_eq + on_Trel_eq (P' (Γ ,,, inst_case_branch_context p0 br) (Γ' ,,, inst_case_context pparams1 p0.(puinst) br'.(bcontext))) bbody bcontext br br') brs0 brs1 -> - nth_error brs1 c = Some br -> + nth_error brs1 c = Some br -> #|args1| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat -> P Γ Γ' (tCase ci p0 (mkApps (tConstruct ci.(ci_ind) c u) args0) brs0) (iota_red ci.(ci_npar) (set_pparams p0 pparams1) args1 br)) -> @@ -507,11 +507,11 @@ Section ParallelReduction. Pctxover Γ Γ' (PCUICCases.inst_case_predicate_context p0) (PCUICCases.inst_case_predicate_context p1) -> pred1 (Γ ,,, inst_case_context p0.(pparams) p0.(puinst) p0.(pcontext)) (Γ' ,,, inst_case_context p1.(pparams) p1.(puinst) p1.(pcontext)) p0.(preturn) p1.(preturn) -> - P (Γ ,,, inst_case_context p0.(pparams) p0.(puinst) p0.(pcontext)) + P (Γ ,,, inst_case_context p0.(pparams) p0.(puinst) p0.(pcontext)) (Γ' ,,, inst_case_context p1.(pparams) p1.(puinst) p1.(pcontext)) p0.(preturn) p1.(preturn) -> - All2 (fun br br' => + All2 (fun br br' => Pctxover Γ Γ' (inst_case_branch_context p0 br) (inst_case_branch_context p1 br') × - on_Trel_eq + on_Trel_eq (P' (Γ ,,, inst_case_branch_context p0 br) (Γ' ,,, inst_case_branch_context p1 br')) bbody bcontext br br') brs0 brs1 -> P Γ Γ' (tCase ci p0 (mkApps (tCoFix mfix0 idx) args0) brs0) @@ -561,7 +561,7 @@ Section ParallelReduction. P Γ Γ' t0 t1 -> pred1 (Γ,, vdef na d0 t0) (Γ',,vdef na d1 t1) b0 b1 -> P (Γ,, vdef na d0 t0) (Γ',,vdef na d1 t1) b0 b1 -> P Γ Γ' (tLetIn na d0 t0 b0) (tLetIn na d1 t1 b1)) -> - + (forall (Γ Γ' : context) ci p0 p1 c0 c1 brs0 brs1, pred1_ctx Γ Γ' -> Pctx Γ Γ' -> @@ -569,13 +569,13 @@ Section ParallelReduction. p0.(puinst) = p1.(puinst) -> p0.(pcontext) = p1.(pcontext) -> Pctxover Γ Γ' (PCUICCases.inst_case_predicate_context p0) (PCUICCases.inst_case_predicate_context p1) -> - pred1 (Γ ,,, inst_case_context p0.(pparams) p0.(puinst) p0.(pcontext)) + pred1 (Γ ,,, inst_case_context p0.(pparams) p0.(puinst) p0.(pcontext)) (Γ' ,,, inst_case_context p1.(pparams) p1.(puinst) p1.(pcontext)) p0.(preturn) p1.(preturn) -> - P (Γ ,,, inst_case_context p0.(pparams) p0.(puinst) p0.(pcontext)) + P (Γ ,,, inst_case_context p0.(pparams) p0.(puinst) p0.(pcontext)) (Γ' ,,, inst_case_context p1.(pparams) p1.(puinst) p1.(pcontext)) p0.(preturn) p1.(preturn) -> - All2 (fun br br' => + All2 (fun br br' => Pctxover Γ Γ' (inst_case_branch_context p0 br) (inst_case_branch_context p1 br') × - on_Trel_eq + on_Trel_eq (P' (Γ ,,, inst_case_branch_context p0 br) (Γ' ,,, inst_case_branch_context p1 br')) bbody bcontext br br') brs0 brs1 -> pred1 Γ Γ' c0 c1 -> @@ -642,21 +642,21 @@ Section ParallelReduction. - apply Hctx, (on_contexts_impl a). exact a. intros. apply (aux _ _ _ _ X20). - eapply (All2_All2_prop (P:=pred1) (Q:=P') a0 ((extendP aux) Γ Γ')). - eapply (All2_All2_prop a1 (extendP aux Γ Γ')). - - eapply (All2_branch_prop + - eapply (All2_branch_prop (P:=fun Γ Γ' br br' => (pred1_ctx_over Γ Γ') (inst_case_branch_context p0 br) (inst_case_context params' (puinst p0) (bcontext br')) * (pred1 (Γ,,, inst_case_branch_context p0 br) (Γ',,, inst_case_context params' (puinst p0) (bcontext br)) (bbody br) (bbody br') × bcontext br = bcontext br')) - (Q:=fun Γ Γ' br0 br' => + (Q:=fun Γ Γ' br0 br' => Pctxover Γ Γ' (inst_case_branch_context p0 br0) (inst_case_context params' (puinst p0) (bcontext br')) * (P' (Γ,,, inst_case_branch_context p0 br0) (Γ',,, inst_case_context params' (puinst p0) (bcontext br')) (bbody br0) (bbody br') × bcontext br0 = bcontext br')) a2). intros x y [? []]. split; [|split]; auto. - * apply Hctxover => //. + * apply Hctxover => //. apply (on_contexts_impl a aux). apply (Hctx _ _ a), (on_contexts_impl a aux). apply (on_contexts_impl a3 (extend_over aux Γ Γ')). @@ -675,7 +675,7 @@ Section ParallelReduction. * eapply (All2_All2_prop (P:=pred1) (Q:=P') a2 (extendP aux Γ Γ')). * eapply (All2_All2_prop (P:=pred1) (Q:=P') a3 (extendP aux Γ Γ')). * apply (Hctxover _ _ _ _ a (on_contexts_impl a aux) - (Hctx _ _ a (on_contexts_impl a aux)) + (Hctx _ _ a (on_contexts_impl a aux)) a4 (on_contexts_impl a4 (extend_over aux Γ Γ'))). * eapply (All2_branch_prop (P:=fun Γ Γ' br br' => @@ -684,13 +684,13 @@ Section ParallelReduction. (pred1 (Γ,,, inst_case_branch_context p0 br) (Γ',,, inst_case_branch_context p1 br') (bbody br) (bbody br') × bcontext br = bcontext br')) - (Q:=fun Γ Γ' br0 br' => + (Q:=fun Γ Γ' br0 br' => Pctxover Γ Γ' (inst_case_branch_context p0 br0) (inst_case_branch_context p1 br') * (P' (Γ,,, inst_case_branch_context p0 br0) (Γ',,, inst_case_branch_context p1 br') (bbody br0) (bbody br') × bcontext br0 = bcontext br')) a5). - intros x y [? []]. + intros x y [? []]. split; auto. 2:split => //. + apply (Hctxover _ _ _ _ a (on_contexts_impl a aux) (Hctx _ _ a (on_contexts_impl a aux)) a6 (on_contexts_impl a6 (extend_over aux Γ Γ'))). @@ -718,13 +718,13 @@ Section ParallelReduction. (pred1 (Γ,,, inst_case_branch_context p0 br) (Γ',,, inst_case_branch_context p1 br') (bbody br) (bbody br') × bcontext br = bcontext br')) - (Q:=fun Γ Γ' br0 br' => + (Q:=fun Γ Γ' br0 br' => Pctxover Γ Γ' (inst_case_branch_context p0 br0) (inst_case_branch_context p1 br') * (P' (Γ,,, inst_case_branch_context p0 br0) (Γ',,, inst_case_branch_context p1 br') (bbody br0) (bbody br') × bcontext br0 = bcontext br')) a2). - intros x y [? []]. + intros x y [? []]. split; auto. 2:split => //. + apply (Hctxover _ _ _ _ a (on_contexts_impl a aux) (Hctx _ _ a (on_contexts_impl a aux)) a3 (on_contexts_impl a3 (extend_over aux Γ Γ'))). @@ -762,8 +762,8 @@ Section ParallelReduction. try solve [eexists; split; constructor; eauto]. Qed. - Lemma onctx_rel_pred1_refl Γ Δ : - forall Γ', + Lemma onctx_rel_pred1_refl Γ Δ : + forall Γ', pred1_ctx Γ Γ' -> onctx_rel (fun (Γ : context) (t : term) => @@ -780,8 +780,8 @@ Section ParallelReduction. apply on_contexts_app => //. Qed. - Lemma onctx_rel_pred1_refl' Γ Δ : - forall Γ', + Lemma onctx_rel_pred1_refl' Γ Δ : + forall Γ', pred1_ctx Γ Γ' -> onctx_rel (fun (Γ : context) (t : term) => @@ -821,7 +821,7 @@ Section ParallelReduction. eapply on_contexts_app => //. eapply onctx_rel_pred1_refl => //. * eapply All_All2; tea; solve_all. - + eapply onctx_rel_pred1_refl => //. + + eapply onctx_rel_pred1_refl => //. + eapply b. now eapply on_contexts_app => //; eapply onctx_rel_pred1_refl. - constructor; auto. @@ -930,9 +930,9 @@ Hint Extern 4 (on_contexts_over _ _ _ ?X) => Ltac inv_on_free_vars ::= match goal with - | [ H : is_true (on_free_vars ?P ?t) |- _ ] => + | [ H : is_true (on_free_vars ?P ?t) |- _ ] => progress (cbn in H || rewrite -> on_free_vars_mkApps in H); - (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || + (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || eapply forallb_All in H); intros end. @@ -961,7 +961,7 @@ Section ParallelWeakening. rewrite map_length. generalize (#|mfix|) at 2 3. induction n. simpl. reflexivity. simpl. rewrite - IHn. f_equal. apply H. Qed. - + Lemma lift_rename' n k : lift n k =1 rename (lift_renaming n k). Proof. intros t; apply lift_rename. Qed. @@ -971,7 +971,7 @@ Section ParallelWeakening. lift n k (iota_red pars p args br) = iota_red pars (map_predicate_k id (lift n) k p) (List.map (lift n k) args) (map_branch_k (lift n) id k br). Proof. - intros hctx hctx'. rewrite !lift_rename'. + intros hctx hctx'. rewrite !lift_rename'. rewrite rename_iota_red //; try (rewrite skipn_length; lia). f_equal; try setoid_rewrite <-lift_rename => //. unfold map_branch_k, rename_branch, map_branch_shift. @@ -991,16 +991,16 @@ Section ParallelWeakening. now rewrite mapi_context_fold. Qed. - Lemma All_decls_map P (f g : term -> term) d d' : + Lemma All_decls_map P (f g : term -> term) d d' : All_decls (fun x y => P (f x) (g y)) d d' -> All_decls P (map_decl f d) (map_decl g d'). Proof. intros []; constructor; auto. Qed. - Lemma on_contexts_context_k P (f g : nat -> term -> term) ctx ctx' : + Lemma on_contexts_context_k P (f g : nat -> term -> term) ctx ctx' : All2_fold (fun Γ Γ' d d' => P (map_decl (f #|Γ|) d) (map_decl (g #|Γ'|) d')) ctx ctx' -> - All2 P (fold_context_k f ctx) (fold_context_k g ctx'). + All2 P (fold_context_k f ctx) (fold_context_k g ctx'). Proof. induction 1. constructor. rewrite !fold_context_k_snoc0. now constructor. @@ -1009,7 +1009,7 @@ Qed. Hint Resolve urenaming_vass urenaming_vdef : pcuic. Lemma on_contexts_fold_context_k P (f g : nat -> term -> term) ctx ctx' : - All2_fold (on_decls (fun Γ Γ' t t' => P (fold_context_k f Γ) (fold_context_k g Γ') + All2_fold (on_decls (fun Γ Γ' t t' => P (fold_context_k f Γ) (fold_context_k g Γ') (f #|Γ| t) (g #|Γ'| t'))) ctx ctx' -> All2_fold (on_decls P) (fold_context_k f ctx) (fold_context_k g ctx'). Proof. @@ -1019,7 +1019,7 @@ Qed. intros par par' x y H. now rewrite !mapi_context_fold. Qed. - + Lemma on_contexts_rename_context Σ Δ Δ' Γ Γ' f : All2_fold (fun Γ Γ' : context => @@ -1046,17 +1046,17 @@ Qed. now move/andP: H => /= []. now move/andP: H => /= []. Qed. - + (** This not only proves that parallel reduction has renaming, it also ensures that it only looks at the variables actually used in the term/context. - This lemma can later be used to show weakening but also verify that + This lemma can later be used to show weakening but also verify that strenghtening is admissible for parallel reduction: i.e. the case of - a renaming that is only defined on a subset of the variables of + a renaming that is only defined on a subset of the variables of the context. *) - Lemma pred1_rename {Σ} {wfΣ : wf Σ} : + Lemma pred1_rename {Σ} {wfΣ : wf Σ} : (forall Γ Γ' u v, pred1 Σ Γ Γ' u v -> forall {P f Δ Δ'}, pred1_ctx Σ Δ Δ' -> @@ -1068,7 +1068,7 @@ Qed. (forall (Γ Γ' : context) (Δ Δ' : context), pred1_ctx Σ Γ Γ' -> pred1_ctx_over Σ Γ Γ' Δ Δ' -> - forall P f Δ0 Δ'0, + forall P f Δ0 Δ'0, urenaming P Δ0 Γ f -> urenaming P Δ'0 Γ' f -> pred1_ctx Σ Δ0 Δ'0 -> @@ -1078,9 +1078,9 @@ Qed. Proof using cf. set (Pctx := fun (Γ Γ' : context) => pred1_ctx Σ Γ Γ'). - refine (pred1_ind_all_ctx Σ _ Pctx _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros *; intros; + refine (pred1_ind_all_ctx Σ _ Pctx _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros *; intros; subst Pctx; - rename_all_hyps; try subst Γ Γ'; + rename_all_hyps; try subst Γ Γ'; lazymatch goal with | |- context [tCase _ _ _ _] => idtac | |- _ => simplify_IH_hyps @@ -1127,7 +1127,7 @@ Qed. } 1:{ exact predΓ'. } - + - rename uf0 into uf'. rename H into onΓ; rename H0 into onΔ. eapply on_contexts_fold_context_k. @@ -1157,12 +1157,12 @@ Qed. eapply (forall_P (PCUICOnFreeVars.shiftnP 1 P) (shiftn 1 f)); auto with pcuic. repeat (constructor; eauto). - - (* Let *) + - (* Let *) rewrite rename_subst10. econstructor; eauto. eapply (forall_P1 (PCUICOnFreeVars.shiftnP 1 P) (shiftn 1 f)); eauto with pcuic. repeat (constructor; eauto). - + - (* Rel *) rewrite lift0_rename /rshiftk. cbn in H0. @@ -1188,7 +1188,7 @@ Qed. eapply forallb_All in p4. eapply All2_All_mix_left in X3; tea. rewrite rename_iota_red //. - * rewrite skipn_length; lia. + * rewrite skipn_length; lia. * eapply All2_nth_error_Some_right in X3 as [br' [nthbr [? []]]]; tea. move/andP: i => [] clbctx onfvs. destruct p5. @@ -1227,7 +1227,7 @@ Qed. rewrite on_free_vars_ctx_on_ctx_free_vars. eapply on_free_vars_ctx_inst_case_context; trea. } - - (* Fixpoint unfolding *) + - (* Fixpoint unfolding *) rewrite 2!rename_mkApps. simpl. inv_on_free_vars. econstructor; tas. 3:eapply rename_unfold_fix; tea. @@ -1289,11 +1289,11 @@ Qed. rewrite {2}heq_pcontext. eapply forall_P0; tea. now eapply on_free_vars_ctx_inst_case_context. * relativize #|pcontext p0|; [eapply urenaming_context|]; len; trea. - * rewrite heq_pcontext. + * rewrite heq_pcontext. relativize #|pcontext p1|; [eapply urenaming_context|]; len; trea. - * relativize #|pcontext p0|. erewrite on_ctx_free_vars_extend, H3. cbn. + * relativize #|pcontext p0|. erewrite on_ctx_free_vars_extend, H3. cbn. now eapply on_free_vars_ctx_inst_case_context. now len. - + eapply All2_map. + + eapply All2_map. eapply forallb_All in p5. eapply All2_All_mix_left in X9; tea. eapply (All2_impl X9). move=> x y [] /andP[] onpars onbod [] IHbctx [] [] hbod IHbod eq. unfold on_Trel. @@ -1313,7 +1313,7 @@ Qed. { relativize #|bcontext x|. erewrite on_ctx_free_vars_concat, H3. rewrite on_free_vars_ctx_on_ctx_free_vars. eapply on_free_vars_ctx_inst_case_context; solve_all. now len. } - + - rewrite 2!rename_mkApps. simpl. cbn in H0. repeat inv_on_free_vars. econstructor; tea. 3:eapply rename_unfold_cofix; tea. @@ -1378,7 +1378,7 @@ Qed. { eapply on_contexts_app => //. eapply a0; tea. eapply on_free_vars_ctx_inst_case_context; trea. solve_all. } { relativize #|bcontext x|; [eapply urenaming_context|]; len; trea. } - { rewrite /inst_case_branch_context. + { rewrite /inst_case_branch_context. relativize #|bcontext x|; [eapply urenaming_context|]; len; trea. now rewrite b. } { relativize #|bcontext x|; [erewrite on_ctx_free_vars_concat, H2|]; len; trea. @@ -1415,7 +1415,7 @@ Qed. Lemma weakening_pred1 {Σ} {wfΣ : wf Σ} {P Γ Γ' Γ'' Δ Δ' Δ'' M N} : pred1 Σ (Γ ,,, Γ') (Δ ,,, Δ') M N -> - on_ctx_free_vars (PCUICOnFreeVars.shiftnP #|Γ'| P) (Γ ,,, Γ') -> + on_ctx_free_vars (PCUICOnFreeVars.shiftnP #|Γ'| P) (Γ ,,, Γ') -> on_free_vars (PCUICOnFreeVars.shiftnP #|Γ'| P) M -> #|Γ| = #|Δ| -> on_contexts_over (pred1 Σ) Γ Δ Γ'' Δ'' -> @@ -1454,7 +1454,7 @@ Qed. Lemma weakening_pred1_pred1 {Σ} {wfΣ : wf Σ} {P Γ Δ Γ' Δ' M N} : pred1_ctx_over Σ Γ Δ Γ' Δ' -> - on_ctx_free_vars P Γ -> + on_ctx_free_vars P Γ -> on_free_vars P M -> pred1 Σ Γ Δ M N -> pred1 Σ (Γ ,,, Γ') (Δ ,,, Δ') (lift0 #|Γ'| M) (lift0 #|Δ'| N). @@ -1468,7 +1468,7 @@ Qed. Lemma weakening_pred1_0 {Σ} {wfΣ : wf Σ} {P Γ Δ Γ' M N} : pred1 Σ Γ Δ M N -> - on_ctx_free_vars P Γ -> + on_ctx_free_vars P Γ -> on_free_vars P M -> pred1 Σ (Γ ,,, Γ') (Δ ,,, Γ') (lift0 #|Γ'| M) (lift0 #|Γ'| N). Proof. @@ -1681,7 +1681,7 @@ Section ParallelSubstitution. forall decl, nth_error Γ x = Some decl -> match decl_body decl return Type with | Some b => - (∑ b', + (∑ b', (* The Γ' context necessarily has a let-in for i and [σ i] must reduce to it in Δ *) option_map decl_body (nth_error Γ' x) = Some (Some b') × (pred1 Σ Δ Δ' (σ x) (b'.[↑^(S x) ∘s τ]))) @@ -1702,7 +1702,7 @@ Section ParallelSubstitution. Lemma simpl_pred Γ Γ' t t' u u' : t = t' -> u = u' -> pred1 Σ Γ Γ' t' u' -> pred1 Σ Γ Γ' t u. Proof. now intros -> ->. Qed. - Lemma pred1_subst_ext (P P' Q Q' : nat -> bool) Γ Γ' Δ Δ' σ σ' τ τ' : + Lemma pred1_subst_ext (P P' Q Q' : nat -> bool) Γ Γ' Δ Δ' σ σ' τ τ' : P =1 P' -> Q =1 Q' -> σ =1 σ' -> @@ -1742,7 +1742,7 @@ Section ParallelSubstitution. split. apply on_ctx_free_vars_snoc_ass => //. intros x hx. rewrite /shiftnP /= in hx. destruct x; simpl. split; auto. - split. + split. eapply pred1_refl_gen. constructor; eauto with pcuic. now constructor. intros decl [=]. subst decl. simpl => //. simpl in hx. rewrite Nat.sub_0_r in hx. @@ -1757,7 +1757,7 @@ Section ParallelSubstitution. intros decl hnth. specialize (y decl hnth). destruct decl_body => //. destruct y as [b' []]; exists b' => //. split => //. - eapply simpl_pred. unfold subst_compose. now rewrite -(lift0_inst 1). + eapply simpl_pred. unfold subst_compose. now rewrite -(lift0_inst 1). rewrite -(Nat.add_1_r (S x)). rewrite -shiftk_compose subst_compose_assoc shift_Up_comm -subst_compose_assoc shiftk_shift -inst_assoc - !(lift0_inst 1). reflexivity. @@ -1765,7 +1765,7 @@ Section ParallelSubstitution. repeat (constructor; auto). Qed. - Lemma pred1_subst_vdef_Up {wfΣ : wf Σ} (P Q : nat -> bool) (Γ Γ' : context) (na : aname) + Lemma pred1_subst_vdef_Up {wfΣ : wf Σ} (P Q : nat -> bool) (Γ Γ' : context) (na : aname) (b0 b1 t0 t1 : term) (Δ Δ' : context) (σ τ : nat -> term) : on_free_vars P t0 -> on_free_vars P b0 -> @@ -1810,15 +1810,15 @@ Section ParallelSubstitution. Lemma leb_S x y : S x <= y -> x term -> term) Γ n : - nth_error (fold_context_k f Γ) n = + Lemma nth_error_fold_context_k (f : nat -> term -> term) Γ n : + nth_error (fold_context_k f Γ) n = option_map (map_decl (f (Nat.pred #|Γ| - n))) (nth_error Γ n). Proof. rewrite -mapi_context_fold. induction Γ in n |- *; simpl; destruct n; cbn; auto. - now rewrite Nat.sub_0_r. - rewrite IHΓ. lia_f_equal. - Qed. + Qed. Lemma pred1_subst_Upn {wfΣ : wf Σ} {P Q} {Γ Γ' Δ Δ' σ τ Δ0 Δ1 n} : n = #|Δ0| -> @@ -1854,11 +1854,11 @@ Section ParallelSubstitution. eapply nth_error_pred1_ctx_l in H; tea. 2:now erewrite hnth. destruct H as [body' [eqb ond]]. - exists body'. split; auto. + exists body'. split; auto. rewrite nth_error_app_lt //. lia. eapply simpl_pred; revgoals. 3:reflexivity. econstructor. eapply on_contexts_app => //. - rewrite nth_error_app_lt. len. len in l. + rewrite nth_error_app_lt. len. len in l. rewrite /inst_context nth_error_fold_context_k option_map_two /=. destruct (nth_error Δ1 x) => //. noconf eqb. cbn. rewrite H /= //. @@ -1882,7 +1882,7 @@ Section ParallelSubstitution. relativize #|Δ1|. relativize #|Δ0|. eapply weakening_pred1_pred1; tea. now len. len. rewrite -len0. exact pred. all:now len. - * intros decl hnth. + * intros decl hnth. rewrite nth_error_app_ge in hnth. lia. specialize (Hrel decl hnth). destruct decl_body => //. @@ -1917,14 +1917,14 @@ Section ParallelSubstitution. eapply pred1_subst_Upn => //. Qed. Hint Resolve pred1_subst_up : pcuic. - + Ltac simpl_pred := eapply simpl_pred; rewrite ?up_Upn; unfold Upn, Up, idsn; [autorewrite with sigma; reflexivity| autorewrite with sigma; reflexivity|]. - + Lemma inst_is_constructor: forall (args : list term) (narg : nat) s, is_constructor narg args = true -> is_constructor narg (map (inst s) args) = true. @@ -1943,7 +1943,7 @@ Section ParallelSubstitution. Proof. destruct t; simpl; intros; try discriminate; auto. Qed. - + Lemma All_fold_fold_context_k P (f : nat -> term -> term) Γ : All_fold P (fold_context_k f Γ) <~> All_fold (fun Γ d => P (fold_context_k f Γ) (map_decl (f #|Γ|) d)) Γ. @@ -1951,12 +1951,12 @@ Section ParallelSubstitution. split. - induction Γ; auto. * intros; constructor. - * rewrite fold_context_k_snoc0. + * rewrite fold_context_k_snoc0. intros H; depelim H. constructor; auto. - induction Γ; auto. * intros; constructor. * rewrite fold_context_k_snoc0. - intros H; depelim H. constructor; auto. + intros H; depelim H. constructor; auto. Qed. Lemma All_decls_on_free_vars_map_impl P Q R S f d d' : @@ -1970,7 +1970,7 @@ Section ParallelSubstitution. eapply X; eauto with pcuic; now move: H H0 => /andP[] /= ? ? /andP [] /= //. Qed. - + Lemma strong_substitutivity {wfΣ : wf Σ}: let Pover (Γ Γ' : context) (Δ Δ' : context) := @@ -2056,7 +2056,7 @@ Section ParallelSubstitution. eapply simpl_pred; tea. reflexivity. now rewrite inst_assoc. } (** Zeta *) - 1:{ sigma. + 1:{ sigma. econstructor; eauto. eapply X4; eauto. now rewrite -up_Up. @@ -2106,7 +2106,7 @@ Section ParallelSubstitution. 1-2:now len. 1-2:now sigma. { eapply on_free_vars_ctx_inst_case_context; tea => //. solve_all. } - { rewrite inst_inst_case_context_wf //. + { rewrite inst_inst_case_context_wf //. eapply on_free_vars_ctx_inst_case_context; tea; len => //. solve_all. } tea. rewrite /inst_case_branch_context. @@ -2206,7 +2206,7 @@ Section ParallelSubstitution. eapply on_free_vars_ctx_inst_case_context; tea; solve_all. rewrite !inst_inst_case_context_wf //. eapply on_free_vars_ctx_inst_case_context; tea; solve_all. - + + simpl. rewrite /PCUICCases.inst_case_predicate_context /=. rewrite - !inst_inst_case_context_wf //. @@ -2245,10 +2245,10 @@ Section ParallelSubstitution. all:len => //; try lia. { eapply on_free_vars_ctx_inst_case_context; tea; solve_all. } { rewrite !inst_inst_case_context_wf //. - eapply on_free_vars_ctx_inst_case_context; tea; solve_all. } + eapply on_free_vars_ctx_inst_case_context; tea; solve_all. } eapply pred1_pred1_ctx in a4. eapply on_contexts_app_inv => //. - now rewrite (on_contexts_length X). + now rewrite (on_contexts_length X). 2:rewrite b0 //. eapply a2; tea. eapply on_free_vars_ctx_inst_case_context; tea; solve_all. @@ -2270,7 +2270,7 @@ Section ParallelSubstitution. instantiate (1 := (map (map_def (inst τ) (inst (⇑^#|mfix1| τ))) mfix1)). rewrite !inst_fix_context; auto. rewrite !inst_fix_context; auto. - + red. eapply All2_map. + + red. eapply All2_map. red in X3. pose proof (All2_length X3). solve_all; unfold on_Trel in *; simpl in *; intuition eauto. @@ -2302,7 +2302,7 @@ Section ParallelSubstitution. econstructor; eauto with pcuic. - eapply pred1_refl_gen. now apply pred1_subst_pred1_ctx in Hrel. - + - (* Proj-Construct *) simpl. sigma. cbn in ons; inv_on_free_vars. simpl in onis. rewrite inst_mkApps /= in onis. inv_on_free_vars. @@ -2363,7 +2363,7 @@ Section ParallelSubstitution. eapply b; tea. rewrite /inst_case_branch_context. rewrite - !inst_inst_case_context_wf //. - now rewrite /= -(All2_length X1) -b0. + now rewrite /= -(All2_length X1) -b0. relativize #|bcontext x|. relativize #|bcontext y|. eapply pred1_subst_up; len => //. eapply on_free_vars_ctx_inst_case_context; tea; solve_all. @@ -2459,9 +2459,9 @@ Section ParallelSubstitution. Lemma psubst_pred1_subst {wfΣ : wf Σ} {Γ Γ1 Δ Δ1 s s'} : on_ctx_free_vars xpredT Γ -> - pred1_ctx Σ Γ Γ1 -> + pred1_ctx Σ Γ Γ1 -> psubst Σ Γ Γ1 s s' Δ Δ1 -> - All (on_free_vars xpredT) s -> + All (on_free_vars xpredT) s -> pred1_subst xpredT xpredT (Γ,,, Δ) (Γ1,,, Δ1) Γ Γ1 (s ⋅n ids) (s' ⋅n ids). Proof. intros onΓ pΓ ps hs. @@ -2600,7 +2600,7 @@ Section ParallelSubstitution. apply (H redN). Qed. - Lemma substitution0_let_pred1 {wfΣ : wf Σ} {Γ Δ na na' M M' A A' N N'} : + Lemma substitution0_let_pred1 {wfΣ : wf Σ} {Γ Δ na na' M M' A A' N N'} : on_ctx_free_vars xpredT Γ -> on_free_vars xpredT M -> on_free_vars xpredT N -> diff --git a/pcuic/theories/PCUICParallelReductionConfluence.v b/pcuic/theories/PCUICParallelReductionConfluence.v index 9971569a0..778ec94df 100644 --- a/pcuic/theories/PCUICParallelReductionConfluence.v +++ b/pcuic/theories/PCUICParallelReductionConfluence.v @@ -2,11 +2,11 @@ From Coq Require CMorphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICOnOne PCUICAstUtils PCUICTactics PCUICSize PCUICLiftSubst - PCUICSigmaCalculus PCUICUnivSubst PCUICTyping PCUICReduction + PCUICSigmaCalculus PCUICUnivSubst PCUICTyping PCUICReduction PCUICReflect PCUICInduction PCUICClosed PCUICClosedConv PCUICClosedTyp PCUICDepth PCUICOnFreeVars PCUICRenameDef PCUICRenameConv PCUICInstDef PCUICInstConv PCUICWeakeningConv PCUICWeakeningTyp PCUICViews PCUICParallelReduction. - + Require Import ssreflect ssrbool. Require Import Morphisms CRelationClasses. @@ -30,7 +30,7 @@ Section FoldFix. | [] => acc | def :: fixd => fold_fix_context (vass def.(dname) (lift0 #|acc| (rho Γ def.(dtype))) :: acc) fixd - end. + end. End FoldFix. Lemma fold_fix_context_length f Γ l m : #|fold_fix_context f Γ l m| = #|m| + #|l|. @@ -88,7 +88,7 @@ Ltac solve_discr ::= end)). Section Pred1_inversion. - + Lemma pred_snd_nth: forall (Σ : global_env) (Γ Δ : context) (c : nat) (brs1 brs' : list (nat * term)), All2 @@ -122,7 +122,7 @@ Section Pred1_inversion. revert c. induction args using rev_ind; intros; simpl in *. depelim X... exists []. intuition auto. intros. rewrite mkApps_app in X. - depelim X... + depelim X... prepare_discr. apply mkApps_eq_decompose_app in H. rewrite !decompose_app_rec_mkApps in H. noconf H. destruct (IHargs _ X1) as [args' [-> Hargs']]. @@ -257,7 +257,7 @@ Section Pred1_inversion. unfold unfold_fix in e. destruct (nth_error mfix1 idx) eqn:hfix1. noconf e. noconf Hnth'. move: Hann => [=] Hname Hrarg. - all:congruence. + all:congruence. - destruct args0 using rev_ind; noconf Heqfixt. clear IHargs0. rewrite mkApps_app in Heqfixt. noconf Heqfixt. @@ -344,7 +344,7 @@ Section Rho. #[program] Definition map_fix_rho {t} (rho : context -> forall x, depth x < depth t -> term) Γ mfixctx (mfix : mfixpoint term) (H : mfixpoint_depth mfix < depth t) := - (map_In mfix (fun d (H : In d mfix) => {| dname := dname d; + (map_In mfix (fun d (H : In d mfix) => {| dname := dname d; dtype := rho Γ (dtype d) _; dbody := rho (Γ ,,, mfixctx) (dbody d) _; rarg := (rarg d) |})). Next Obligation. @@ -362,14 +362,14 @@ Section Rho. lia. Qed. - Equations? fold_fix_context_wf mfix - (rho : context -> forall x, depth x <= (mfixpoint_depth mfix) -> term) + Equations? fold_fix_context_wf mfix + (rho : context -> forall x, depth x <= (mfixpoint_depth mfix) -> term) (Γ acc : context) : context := fold_fix_context_wf [] rho Γ acc => acc ; - fold_fix_context_wf (d :: mfix) rho Γ acc => + fold_fix_context_wf (d :: mfix) rho Γ acc => fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x _) Γ (vass (dname d) (lift0 #|acc| (rho Γ (dtype d) _)) :: acc). Proof. - lia. unfold def_depth_gen. lia. + lia. unfold def_depth_gen. lia. Qed. Transparent fold_fix_context_wf. @@ -383,9 +383,9 @@ Section Rho. Section rho_ctx. Context (Γ : context). Context (rho : context -> forall x, depth x <= context_depth Γ -> term). - + Program Definition rho_ctx_over_wf := - fold_context_In Γ (fun Γ' d hin => + fold_context_In Γ (fun Γ' d hin => match d with | {| decl_name := na; decl_body := None; decl_type := T |} => vass na (rho Γ' T _) @@ -407,7 +407,7 @@ Section Rho. Qed. End rho_ctx. - Lemma rho_ctx_over_wf_eq (rho : context -> term -> term) (Γ : context) : + Lemma rho_ctx_over_wf_eq (rho : context -> term -> term) (Γ : context) : rho_ctx_over_wf Γ (fun Γ x hin => rho Γ x) = fold_context_term rho Γ. Proof using Type. @@ -416,7 +416,7 @@ Section Rho. now destruct x as [na [b|] ty]; simpl. Qed. Hint Rewrite rho_ctx_over_wf_eq : rho. - + #[program] Definition map_br_wf {t} (rho : context -> forall x, depth x < depth t -> term) Γ (p : PCUICAst.predicate term) @@ -430,14 +430,14 @@ Section Rho. {| bcontext := br.(bcontext); bbody := rho (Γ ,,, bcontext') br.(bbody) |}. - Lemma map_br_map (rho : context -> term -> term) t Γ p l H : - @map_br_wf t (fun Γ x Hx => rho Γ x) Γ p l H = map_br_gen rho Γ p l. - Proof using Type. + Lemma map_br_map (rho : context -> term -> term) t Γ p l H : + @map_br_wf t (fun Γ x Hx => rho Γ x) Γ p l H = map_br_gen rho Γ p l. + Proof using Type. unfold map_br_wf, map_br_gen. now f_equal; autorewrite with rho. - Qed. + Qed. Hint Rewrite map_br_map : rho. - #[program] Definition map_brs_wf {t} (rho : context -> forall x, depth x < depth t -> term) Γ + #[program] Definition map_brs_wf {t} (rho : context -> forall x, depth x < depth t -> term) Γ p (l : list (branch term)) (H : list_depth_gen (depth ∘ bbody) l < depth t) := map_In l (fun br (H : In br l) => map_br_wf rho Γ p br _). @@ -445,15 +445,15 @@ Section Rho. eapply (In_list_depth (depth ∘ bbody)) in H. lia. Qed. - Lemma map_brs_map (rho : context -> term -> term) t Γ p l H : - @map_brs_wf t (fun Γ x Hx => rho Γ x) Γ p l H = map (map_br_gen rho Γ p) l. - Proof using Type. + Lemma map_brs_map (rho : context -> term -> term) t Γ p l H : + @map_brs_wf t (fun Γ x Hx => rho Γ x) Γ p l H = map (map_br_gen rho Γ p) l. + Proof using Type. unfold map_brs_wf, map_br_wf. rewrite map_In_spec. apply map_ext => x. now autorewrite with rho. - Qed. + Qed. Hint Rewrite map_brs_map : rho. - #[program] Definition rho_predicate_wf {t} (rho : context -> forall x, depth x < depth t -> term) Γ + #[program] Definition rho_predicate_wf {t} (rho : context -> forall x, depth x < depth t -> term) Γ (p : PCUICAst.predicate term) (H : predicate_depth p < depth t) := let params' := map_terms rho Γ p.(pparams) _ in let pcontext' := inst_case_context params' p.(puinst) p.(pcontext) in @@ -477,14 +477,14 @@ Section Rho. puinst := p.(puinst) ; pcontext := p.(pcontext) ; preturn := rho (Γ ,,, pcontext') p.(preturn) |}. - - Lemma map_terms_map (rho : context -> term -> term) t Γ l H : - @map_terms t (fun Γ x Hx => rho Γ x) Γ l H = map (rho Γ) l. - Proof using Type. + + Lemma map_terms_map (rho : context -> term -> term) t Γ l H : + @map_terms t (fun Γ x Hx => rho Γ x) Γ l H = map (rho Γ) l. + Proof using Type. unfold map_terms. now rewrite map_In_spec. - Qed. + Qed. Hint Rewrite map_terms_map : rho. - + Lemma rho_predicate_map_predicate {t} (rho : context -> term -> term) Γ p (H : predicate_depth p < depth t) : rho_predicate_wf (fun Γ x H => rho Γ x) Γ p H = rho_predicate_gen rho Γ p. @@ -499,21 +499,21 @@ Section Rho. Arguments Nat.max : simpl never. #[program] - Definition rho_iota_red_wf {t} (rho : context -> forall x, depth x < depth t -> term) Γ + Definition rho_iota_red_wf {t} (rho : context -> forall x, depth x < depth t -> term) Γ (p : PCUICAst.predicate term) npar (args : list term) (br : branch term) (H : depth (bbody br) < depth t) := let bctx := inst_case_branch_context p br in (* let rhobctx := rho_ctx_over_wf bctx (fun Γ' x Hx => rho (Γ ,,, Γ') x _) in *) let br' := map_br_wf rho Γ p br _ in subst0 (List.rev (skipn npar args)) (expand_lets bctx (bbody br')). - - Definition rho_iota_red_gen (rho : context -> term -> term) Γ + + Definition rho_iota_red_gen (rho : context -> term -> term) Γ (p : PCUICAst.predicate term) npar (args : list term) (br : branch term) := let bctx := inst_case_branch_context p br in (* let rhobctx := fold_context_term (fun Γ' => rho (Γ ,,, Γ')) bctx in *) subst0 (List.rev (skipn npar args)) (expand_lets bctx (rho (Γ ,,, bctx) (bbody br))). - Lemma rho_iota_red_wf_gen (rho : context -> term -> term) t Γ p npar args br H : + Lemma rho_iota_red_wf_gen (rho : context -> term -> term) t Γ p npar args br H : rho_iota_red_wf (t:=t) (fun Γ x H => rho Γ x) Γ p npar args br H = rho_iota_red_gen rho Γ p npar args br. Proof using Type. @@ -522,126 +522,126 @@ Section Rho. Hint Rewrite @rho_iota_red_wf_gen : rho. Lemma bbody_branch_depth brs p : - list_depth_gen (depth ∘ bbody) brs < + list_depth_gen (depth ∘ bbody) brs < S (list_depth_gen (branch_depth_gen depth p) brs). Proof using Type. rewrite /branch_depth_gen. induction brs; simpl; auto. lia. Qed. - (** Needs well-founded recursion on the depth of terms as we should reduce + (** Needs well-founded recursion on the depth of terms as we should reduce strings of applications in one go. *) - Equations? rho (Γ : context) (t : term) : term by wf (depth t) := - rho Γ (tApp t u) with view_lambda_fix_app t u := - { | fix_lambda_app_lambda na T b [] u := + Equations? rho (Γ : context) (t : term) : term by wf (depth t) := + rho Γ (tApp t u) with view_lambda_fix_app t u := + { | fix_lambda_app_lambda na T b [] u := (rho (vass na (rho Γ T) :: Γ) b) {0 := rho Γ u}; | fix_lambda_app_lambda na T b (a :: l) u := mkApps ((rho (vass na (rho Γ T) :: Γ) b) {0 := rho Γ a}) (map_terms rho Γ (l ++ [u]) _); | fix_lambda_app_fix mfix idx l u := - let mfixctx := fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x) Γ [] in + let mfixctx := fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x) Γ [] in let mfix' := map_fix_rho (t:=tFix mfix idx) (fun Γ x Hx => rho Γ x) Γ mfixctx mfix _ in let args := map_terms rho Γ (l ++ [u]) _ in - match unfold_fix mfix' idx with + match unfold_fix mfix' idx with | Some (rarg, fn) => if is_constructor rarg (l ++ [u]) then mkApps fn args else mkApps (tFix mfix' idx) args | None => mkApps (tFix mfix' idx) args end ; - | fix_lambda_app_other t u nisfixlam := tApp (rho Γ t) (rho Γ u) } ; - rho Γ (tLetIn na d t b) => (subst10 (rho Γ d) (rho (vdef na (rho Γ d) (rho Γ t) :: Γ) b)); - rho Γ (tRel i) with option_map decl_body (nth_error Γ i) := { - | Some (Some body) => (lift0 (S i) body); - | Some None => tRel i; - | None => tRel i }; + | fix_lambda_app_other t u nisfixlam := tApp (rho Γ t) (rho Γ u) } ; + rho Γ (tLetIn na d t b) => (subst10 (rho Γ d) (rho (vdef na (rho Γ d) (rho Γ t) :: Γ) b)); + rho Γ (tRel i) with option_map decl_body (nth_error Γ i) := { + | Some (Some body) => (lift0 (S i) body); + | Some None => tRel i; + | None => tRel i }; rho Γ (tCase ci p x brs) with inspect (decompose_app x) := - { | exist (f, args) eqx with view_construct_cofix f := - { | construct_cofix_construct ind' c u with eq_inductive ci.(ci_ind) ind' := - { | true with inspect (nth_error brs c) => + { | exist (f, args) eqx with view_construct_cofix f := + { | construct_cofix_construct ind' c u with eq_inductive ci.(ci_ind) ind' := + { | true with inspect (nth_error brs c) => { | exist (Some br) eqbr => - if eqb #|args| + if eqb #|args| (ci_npar ci + context_assumptions (bcontext br)) then - let p' := rho_predicate_wf rho Γ p _ in - let args' := map_terms rho Γ args _ in + let p' := rho_predicate_wf rho Γ p _ in + let args' := map_terms rho Γ args _ in rho_iota_red_wf rho Γ p' ci.(ci_npar) args' br _ - else - let p' := rho_predicate_wf rho Γ p _ in + else + let p' := rho_predicate_wf rho Γ p _ in let brs' := map_brs_wf rho Γ p' brs _ in let x' := rho Γ x in tCase ci p' x' brs'; - | exist None eqbr => - let p' := rho_predicate_wf rho Γ p _ in + | exist None eqbr => + let p' := rho_predicate_wf rho Γ p _ in let brs' := map_brs_wf rho Γ p' brs _ in let x' := rho Γ x in tCase ci p' x' brs' }; - | false => - let p' := rho_predicate_wf rho Γ p _ in - let x' := rho Γ x in - let brs' := map_brs_wf rho Γ p' brs _ in - tCase ci p' x' brs' }; + | false => + let p' := rho_predicate_wf rho Γ p _ in + let x' := rho Γ x in + let brs' := map_brs_wf rho Γ p' brs _ in + tCase ci p' x' brs' }; | construct_cofix_cofix mfix idx := - let p' := rho_predicate_wf rho Γ p _ in - let args' := map_terms rho Γ args _ in - let brs' := map_brs_wf rho Γ p' brs _ in - let mfixctx := fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x) Γ [] in + let p' := rho_predicate_wf rho Γ p _ in + let args' := map_terms rho Γ args _ in + let brs' := map_brs_wf rho Γ p' brs _ in + let mfixctx := fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x) Γ [] in let mfix' := map_fix_rho (t:=tCase ci p x brs) rho Γ mfixctx mfix _ in match nth_error mfix' idx with | Some d => tCase ci p' (mkApps (subst0 (cofix_subst mfix') (dbody d)) args') brs' | None => tCase ci p' (rho Γ x) brs' - end; - | construct_cofix_other _ nconscof => - let p' := rho_predicate_wf rho Γ p _ in - let x' := rho Γ x in - let brs' := map_brs_wf rho Γ p' brs _ in + end; + | construct_cofix_other _ nconscof => + let p' := rho_predicate_wf rho Γ p _ in + let x' := rho Γ x in + let brs' := map_brs_wf rho Γ p' brs _ in tCase ci p' x' brs' } }; rho Γ (tProj p x) with inspect (decompose_app x) := { | exist (f, args) eqx with view_construct0_cofix f := - | construct0_cofix_construct ind u with - inspect (nth_error (map_terms rho Γ args _) (p.(proj_npars) + p.(proj_arg))) := { - | exist (Some arg1) eq => + | construct0_cofix_construct ind u with + inspect (nth_error (map_terms rho Γ args _) (p.(proj_npars) + p.(proj_arg))) := { + | exist (Some arg1) eq => if eq_inductive p.(proj_ind) ind then arg1 else tProj p (rho Γ x); - | exist None neq => tProj p (rho Γ x) }; - | construct0_cofix_cofix mfix idx := + | exist None neq => tProj p (rho Γ x) }; + | construct0_cofix_cofix mfix idx := let args' := map_terms rho Γ args _ in - let mfixctx := fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x) Γ [] in + let mfixctx := fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x) Γ [] in let mfix' := map_fix_rho (t:=tProj p x) rho Γ mfixctx mfix _ in match nth_error mfix' idx with | Some d => tProj p (mkApps (subst0 (cofix_subst mfix') (dbody d)) args') | None => tProj p (rho Γ x) end; | construct0_cofix_other f nconscof => tProj p (rho Γ x) } ; - rho Γ (tConst c u) with lookup_env Σ c := { - | Some (ConstantDecl decl) with decl.(cst_body) := { - | Some body => subst_instance u body; - | None => tConst c u }; - | _ => tConst c u }; - rho Γ (tLambda na t u) => tLambda na (rho Γ t) (rho (vass na (rho Γ t) :: Γ) u); - rho Γ (tProd na t u) => tProd na (rho Γ t) (rho (vass na (rho Γ t) :: Γ) u); - rho Γ (tVar i) => tVar i; - rho Γ (tEvar n l) => tEvar n (map_terms rho Γ l _); - rho Γ (tSort s) => tSort s; - rho Γ (tFix mfix idx) => - let mfixctx := fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x) Γ [] in - tFix (map_fix_rho (t:=tFix mfix idx) (fun Γ x Hx => rho Γ x) Γ mfixctx mfix _) idx; - rho Γ (tCoFix mfix idx) => - let mfixctx := fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x) Γ [] in - tCoFix (map_fix_rho (t:=tCoFix mfix idx) rho Γ mfixctx mfix _) idx; + rho Γ (tConst c u) with lookup_env Σ c := { + | Some (ConstantDecl decl) with decl.(cst_body) := { + | Some body => subst_instance u body; + | None => tConst c u }; + | _ => tConst c u }; + rho Γ (tLambda na t u) => tLambda na (rho Γ t) (rho (vass na (rho Γ t) :: Γ) u); + rho Γ (tProd na t u) => tProd na (rho Γ t) (rho (vass na (rho Γ t) :: Γ) u); + rho Γ (tVar i) => tVar i; + rho Γ (tEvar n l) => tEvar n (map_terms rho Γ l _); + rho Γ (tSort s) => tSort s; + rho Γ (tFix mfix idx) => + let mfixctx := fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x) Γ [] in + tFix (map_fix_rho (t:=tFix mfix idx) (fun Γ x Hx => rho Γ x) Γ mfixctx mfix _) idx; + rho Γ (tCoFix mfix idx) => + let mfixctx := fold_fix_context_wf mfix (fun Γ x Hx => rho Γ x) Γ [] in + tCoFix (map_fix_rho (t:=tCoFix mfix idx) rho Γ mfixctx mfix _) idx; rho Γ x => x. Proof. all:try abstract lia. - Ltac d := + Ltac d := match goal with |- context [depth (mkApps ?f ?l)] => move: (depth_mkApps f l); cbn -[Nat.max]; try lia end. Ltac invd := match goal with - [ H : decompose_app ?x = _ |- _ ] => + [ H : decompose_app ?x = _ |- _ ] => eapply decompose_app_inv in H; subst x end. all:try abstract (rewrite ?list_depth_app; d). @@ -653,7 +653,7 @@ Section Rho. - clear -eqx Hx. abstract (invd; d). - clear -eqx Hx. abstract (invd; d). Defined. - + Notation rho_predicate := (rho_predicate_gen rho). Notation rho_br := (map_br_gen rho). Notation rho_ctx_over Γ := @@ -672,39 +672,39 @@ Section Rho. Lemma rho_fix_context_length Γ mfix : #|rho_fix_context Γ mfix| = #|mfix|. Proof using Type. now rewrite fold_fix_context_length Nat.add_0_r. Qed. - (* Lemma map_terms_map t Γ l H : @map_terms t (fun Γ x Hx => rho Γ x) Γ l H = map (rho Γ) l. - Proof. + (* Lemma map_terms_map t Γ l H : @map_terms t (fun Γ x Hx => rho Γ x) Γ l H = map (rho Γ) l. + Proof. unfold map_terms. now rewrite map_In_spec. - Qed. + Qed. Hint Rewrite map_terms_map : rho. *) - (* Lemma map_brs_map t Γ l H : - @map_brs t (fun Γ x Hx => rho Γ x) Γ l H = map (fun x => (x.1, rho Γ x.2)) l. - Proof. + (* Lemma map_brs_map t Γ l H : + @map_brs t (fun Γ x Hx => rho Γ x) Γ l H = map (fun x => (x.1, rho Γ x.2)) l. + Proof. unfold map_brs. now rewrite map_In_spec. - Qed. + Qed. Hint Rewrite map_brs_map : rho. *) Definition map_fix (rho : context -> term -> term) Γ mfixctx (mfix : mfixpoint term) := (map (map_def (rho Γ) (rho (Γ ,,, mfixctx))) mfix). - Lemma map_fix_rho_map t Γ mfix ctx H : - @map_fix_rho t (fun Γ x Hx => rho Γ x) Γ ctx mfix H = + Lemma map_fix_rho_map t Γ mfix ctx H : + @map_fix_rho t (fun Γ x Hx => rho Γ x) Γ ctx mfix H = map_fix rho Γ ctx mfix. Proof using Type. unfold map_fix_rho. now rewrite map_In_spec. Qed. Lemma fold_fix_context_wf_fold mfix Γ ctx : - fold_fix_context_wf mfix (fun Γ x _ => rho Γ x) Γ ctx = + fold_fix_context_wf mfix (fun Γ x _ => rho Γ x) Γ ctx = fold_fix_context rho Γ ctx mfix. Proof using Type. - induction mfix in ctx |- *; simpl; auto. + induction mfix in ctx |- *; simpl; auto. Qed. Hint Rewrite map_fix_rho_map fold_fix_context_wf_fold : rho. - Ltac discr_mkApps H := + Ltac discr_mkApps H := let Hf := fresh in let Hargs := fresh in rewrite ?tApp_mkApps -?mkApps_app in H; (eapply mkApps_nApp_inj in H as [Hf Hargs] || @@ -714,10 +714,10 @@ Section Rho. Set Equations With UIP. (* This allows to use decidable equality on terms. *) - (* Most of this is discrimination, we should have a more robust tactic to + (* Most of this is discrimination, we should have a more robust tactic to solve this. *) Lemma rho_app_lambda Γ na ty b a l : - rho Γ (mkApps (tApp (tLambda na ty b) a) l) = + rho Γ (mkApps (tApp (tLambda na ty b) a) l) = mkApps ((rho (vass na (rho Γ ty) :: Γ) b) {0 := rho Γ a}) (map (rho Γ) l). Proof using Type. induction l using rev_ind; autorewrite with rho. @@ -730,9 +730,9 @@ Section Rho. Lemma rho_app_lambda' Γ na ty b l : rho Γ (mkApps (tLambda na ty b) l) = - match l with + match l with | [] => rho Γ (tLambda na ty b) - | a :: l => + | a :: l => mkApps ((rho (vass na (rho Γ ty) :: Γ) b) {0 := rho Γ a}) (map (rho Γ) l) end. Proof using Type. @@ -748,7 +748,7 @@ Section Rho. induction l using rev_ind; autorewrite with rho; auto. simpl. rewrite mkApps_app. simp rho. unshelve erewrite view_lambda_fix_app_other. simpl. - clear; induction l using rev_ind; simpl; auto. + clear; induction l using rev_ind; simpl; auto. rewrite mkApps_app. simpl. apply IHl. simp rho. rewrite IHl. now rewrite map_app mkApps_app. Qed. @@ -761,7 +761,7 @@ Section Rho. induction l using rev_ind; autorewrite with rho; auto. simpl. now simp rho. rewrite mkApps_app. simp rho. unshelve erewrite view_lambda_fix_app_other. simpl. - clear; induction l using rev_ind; simpl; auto. + clear; induction l using rev_ind; simpl; auto. rewrite mkApps_app. simpl. apply IHl. simp rho. rewrite IHl. now rewrite map_app mkApps_app. Qed. @@ -801,10 +801,10 @@ Section Rho. Lemma rho_app_fix Γ mfix idx args : let rhoargs := map (rho Γ) args in - rho Γ (mkApps (tFix mfix idx) args) = + rho Γ (mkApps (tFix mfix idx) args) = match nth_error mfix idx with - | Some d => - if is_constructor (rarg d) args then + | Some d => + if is_constructor (rarg d) args then let fn := (subst0 (map (rho Γ) (fix_subst mfix))) (rho (Γ ,,, fold_fix_context rho Γ [] mfix) (dbody d)) in mkApps fn rhoargs else mkApps (rho Γ (tFix mfix idx)) rhoargs @@ -862,12 +862,12 @@ Section Rho. let (f, args) := decompose_app x in let p' := rho_predicate Γ p in match f with - | tConstruct ind' c u => + | tConstruct ind' c u => if eq_inductive ci.(ci_ind) ind' then match nth_error brs c with - | Some br => + | Some br => if eqb #|args| (ci_npar ci + context_assumptions (bcontext br)) then - let args' := map (rho Γ) args in + let args' := map (rho Γ) args in rho_iota_red Γ p' ci.(ci_npar) args' br else tCase ci p' (rho Γ x) (map (rho_br Γ p') brs) | None => tCase ci p' (rho Γ x) (map (rho_br Γ p') brs) @@ -875,7 +875,7 @@ Section Rho. else tCase ci p' (rho Γ x) (map (rho_br Γ p') brs) | tCoFix mfix idx => match nth_error mfix idx with - | Some d => + | Some d => let fn := (subst0 (map (rho Γ) (cofix_subst mfix))) (rho (Γ ,,, fold_fix_context rho Γ [] mfix) (dbody d)) in tCase ci (rho_predicate Γ p) (mkApps fn (map (rho Γ) args)) (map (rho_br Γ p') brs) @@ -892,7 +892,7 @@ Section Rho. destruct eq_inductive eqn:eqi; simp rho => //. destruct inspect as [[br|] eqnth]; cbv zeta; simp rho; rewrite eqnth //; cbv zeta; simp rho => //. simpl; now simp rho. - cbv zeta. + cbv zeta. simpl. autorewrite with rho. rewrite /map_fix nth_error_map. destruct nth_error => /=. f_equal. f_equal. rewrite (map_cofix_subst rho (fun x y => rho (x ,,, y))) //. @@ -907,7 +907,7 @@ Section Rho. rho Γ (tProj p x) = let (f, args) := decompose_app x in match f with - | tConstruct ind' 0 u => + | tConstruct ind' 0 u => if eq_inductive p.(proj_ind) ind' then match nth_error args (p.(proj_npars) + p.(proj_arg)) with | Some arg1 => rho Γ arg1 @@ -916,7 +916,7 @@ Section Rho. else tProj p (rho Γ x) | tCoFix mfix idx => match nth_error mfix idx with - | Some d => + | Some d => let fn := (subst0 (map (rho Γ) (cofix_subst mfix))) (rho (Γ ,,, fold_fix_context rho Γ [] mfix) (dbody d)) in tProj p (mkApps fn (map (rho Γ) args)) | None => tProj p (rho Γ x) @@ -1001,7 +1001,7 @@ Section Rho. apply IHΓ. Qed. Hint Resolve pres_bodies_inst_context : pcuic. - + Definition ctxmap (Γ Δ : context) (s : nat -> term) := forall x d, nth_error Γ x = Some d -> match decl_body d return Type with @@ -1075,17 +1075,17 @@ Section Rho. Qed. Hint Resolve Upn_ctxmap : pcuic. - Lemma inst_ctxmap Γ Δ Γ' σ : + Lemma inst_ctxmap Γ Δ Γ' σ : ctxmap Γ Δ σ -> ctxmap (Γ ,,, Γ') (Δ ,,, inst_context σ Γ') (⇑^#|Γ'| σ). Proof using Type. intros cmap. - apply Upn_ctxmap => //. + apply Upn_ctxmap => //. apply pres_bodies_inst_context. Qed. Hint Resolve inst_ctxmap : pcuic. - Lemma inst_ctxmap_up Γ Δ Γ' σ : + Lemma inst_ctxmap_up Γ Δ Γ' σ : ctxmap Γ Δ σ -> ctxmap (Γ ,,, Γ') (Δ ,,, inst_context σ Γ') (up #|Γ'| σ). Proof using Type. @@ -1151,7 +1151,7 @@ Section Rho. now sigma. auto. auto. Qed. - + Lemma shift_renaming Γ Δ ctx ctx' r : All2i_len (fun n decl decl' => (decl_body decl' = option_map (fun x => x.[ren (shiftn n r)]) (decl_body decl))) ctx ctx' -> @@ -1200,7 +1200,7 @@ Section Rho. apply All2i_rev_ctx_inv, All2i_mapi. simpl. apply All2i_trivial; auto. now rewrite map_length. Qed. - + Lemma map_fix_rho_rename: forall (mfix : mfixpoint term) (i : nat) (l : list term), (forall t' : term, depth t' < depth (mkApps (tFix mfix i) l) @@ -1233,7 +1233,7 @@ Section Rho. Lemma All_IH {A depth} (l : list A) k (P : A -> Type) : list_depth_gen depth l < k -> - (forall x, depth x < k -> P x) -> + (forall x, depth x < k -> P x) -> All P l. Proof using Type. induction l in k |- *. constructor. @@ -1246,7 +1246,7 @@ Section Rho. Lemma All_IH' {A depth B depth'} (f : A -> B) (l : list A) k (P : B -> Type) : list_depth_gen depth l < k -> (forall x, depth' (f x) <= depth x) -> - (forall x, depth' x < k -> P x) -> + (forall x, depth' x < k -> P x) -> All (fun x => P (f x)) l. Proof using Type. induction l in k |- *. constructor. @@ -1258,7 +1258,7 @@ Section Rho. Transparent fold_context. - Lemma fold_context_mapi_context f g (Γ : context) : + Lemma fold_context_mapi_context f g (Γ : context) : fold_context f (mapi_context g Γ) = fold_context (fun Γ => f Γ ∘ map_decl (g #|Γ|)) Γ. Proof using Type. @@ -1267,7 +1267,7 @@ Section Rho. now rewrite -IHΓ; len. Qed. - Lemma mapi_context_fold_context f g (Γ : context) : + Lemma mapi_context_fold_context f g (Γ : context) : mapi_context f (fold_context (fun Γ => g (mapi_context f Γ)) Γ) = fold_context (fun Γ => map_decl (f #|Γ|) ∘ g Γ) Γ. Proof using Type. @@ -1278,8 +1278,8 @@ Section Rho. Lemma onctx_fold_context_term P Γ (f g : context -> term -> term) : onctx P Γ -> - (forall Γ x, - onctx P Γ -> + (forall Γ x, + onctx P Γ -> fold_context_term f Γ = fold_context_term g Γ -> P x -> f (fold_context_term f Γ) x = g (fold_context_term g Γ) x) -> fold_context_term f Γ = fold_context_term g Γ. @@ -1325,7 +1325,7 @@ Section Rho. now intros i; rewrite !nth_error_nil. Qed. - Lemma ondecl_map (P : term -> Type) f (d : context_decl) : + Lemma ondecl_map (P : term -> Type) f (d : context_decl) : ondecl P (map_decl f d) -> ondecl (fun x => P (f x)) d. Proof using Type. @@ -1358,7 +1358,7 @@ Section Rho. rewrite -/(rename_context r (rho_ctx l)). apply (shiftn_renaming _ _ (rho_ctx_over Γ l) r Hr). tea. Qed. *) - + Lemma rename_rho_ctx_over {ctx} {Γ Δ r P p} : renaming Γ Δ r -> forallb (on_free_vars P) (pparams p) -> @@ -1398,7 +1398,7 @@ Section Rho. solve_all. Qed. - Lemma context_assumptions_fold_context_term f Γ : + Lemma context_assumptions_fold_context_term f Γ : context_assumptions (fold_context_term f Γ) = context_assumptions Γ. Proof using Type. induction Γ => /= //. @@ -1413,7 +1413,7 @@ Section Rho. Lemma inspect_nth_error_rename {r brs u res} (eq : nth_error brs u = res) : ∑ prf, - inspect (nth_error (rename_branches r brs) u) = + inspect (nth_error (rename_branches r brs) u) = exist (option_map (rename_branch r) res) prf. Proof using Type. simpl. rewrite nth_error_map eq. now exists eq_refl. @@ -1435,7 +1435,7 @@ Section Rho. destruct a as [na [b|] ty] => /= //. f_equal. now sigma. Qed. - + Lemma pres_bodies_rename' Γ Δ r ctx : renaming Γ Δ r -> All2i_len @@ -1500,10 +1500,10 @@ Section Rho. rewrite rename_subst0 map_rev map_skipn. f_equal. rewrite List.rev_length /expand_lets /expand_lets_k. rewrite rename_subst0. len. - rewrite skipn_length; try lia. - rewrite hlen. + rewrite skipn_length; try lia. + rewrite hlen. replace (pars + context_assumptions (bcontext br) - pars) - with (context_assumptions (bcontext br)) by lia. + with (context_assumptions (bcontext br)) by lia. rewrite shiftn_add Nat.add_comm rename_shiftnk. relativize (context_assumptions _); [erewrite rename_extended_subst|now len]. assert ((map (rho Δ) (map (rename r) (pparams p)) = map (rename r) (map (rho Γ) (pparams p)))). @@ -1640,7 +1640,7 @@ Section Rho. rewrite -(map_app (rename r) l [a]) -is_constructor_rename H2 //. rewrite rename_mkApps. f_equal. simpl. f_equal. - autorewrite with len. + autorewrite with len. eapply (map_fix_rho_rename mfix i l); eauto. intros. eapply H; eauto. rewrite /=. lia. apply eqargs. @@ -1655,10 +1655,10 @@ Section Rho. pose proof (rho_app_lambda' Γ na ty body (l ++ [arg])). simp rho in H2. rewrite mkApps_app in H2. simpl in H2. simp rho in H2. rewrite {}H2. - simpl. + simpl. rewrite rename_mkApps. simpl. rewrite tApp_mkApps -mkApps_app. - rewrite -(map_app (rename r) _ [_]). + rewrite -(map_app (rename r) _ [_]). rewrite rho_app_lambda'. simpl. assert (All (fun x => rename r (rho Γ x) = rho Δ (rename r x)) (l ++ [arg])). @@ -1675,11 +1675,11 @@ Section Rho. specialize (H body). forward H. { move: (depth_mkApps (tLambda na ty body) l) => /=. lia. } - rewrite inst_mkApps. + rewrite inst_mkApps. specialize (H (vass na (rho Γ ty) :: Γ) (vass na (rho Δ ty.[ren r]) :: Δ) (shiftn 1 r) (shiftnP 1 P)). forward H. eapply shiftn1_renaming; auto. sigma. depelim X. - autorewrite with sigma in H, e, X. + autorewrite with sigma in H, e, X. f_equal. rewrite -H //. sigma. apply inst_ext. rewrite e. @@ -1711,8 +1711,8 @@ Section Rho. assert (map (rename_branch r) (map (rho_br Γ (rho_predicate Γ p)) brs) = (map (rho_br Δ (rho_predicate Δ (rename_predicate r p))) (map (rename_branch r) brs))). { destruct X as [? [? ?]]; red in X0. - simpl in *. rewrite !map_map_compose /rename_branch - /PCUICSigmaCalculus.rename_branch /rho_br /=. + simpl in *. rewrite !map_map_compose /rename_branch + /PCUICSigmaCalculus.rename_branch /rho_br /=. simpl. solve_all. f_equal. rewrite /inst_case_branch_context /=. eapply All_prod_inv in p0 as []. @@ -1742,7 +1742,7 @@ Section Rho. rewrite /= !rho_app_construct /= !rename_mkApps in H. simpl in H. rewrite rho_app_construct in H. apply mkApps_eq_inj in H as [_ Heq] => //. - len; eauto. + len; eauto. { cbn. len. eapply nth_error_forallb in p4; tea. move: p4 => /= /andP[]. rewrite test_context_k_closed_on_free_vars_ctx. now rewrite closedn_ctx_on_free_vars. } @@ -1786,7 +1786,7 @@ Section Rho. (rewrite Upn_comp ?map_length ?fix_subst_length ?map_length //; try now autorewrite with len); []. apply subst_consn_proper => //. - rewrite map_cofix_subst' //. + rewrite map_cofix_subst' //. intros n'; simp rho. simpl; f_equal. now simp rho. rewrite map_cofix_subst' //. simpl. move=> n'; f_equal. simp rho; simpl; simp rho. @@ -1805,8 +1805,8 @@ Section Rho. rewrite -ren_shiftn. rewrite up_Upn. apply (f_equal dbody) in H. simpl in H. sigma in H. now rewrite <-ren_shiftn, up_Upn in H. - now rewrite !map_map_compose in H0. - + now rewrite !map_map_compose in H0. + + rewrite map_map_compose. f_equal; auto. { erewrite -> rho_rename_pred; tea => //. } { simp rho. rewrite !rename_mkApps /= !map_map_compose !compose_map_def /=. @@ -1840,7 +1840,7 @@ Section Rho. simp rho in H. rewrite rename_mkApps in H. eapply mkApps_eq_inj in H as [_ Hargs] => //. rewrite !map_map_compose in Hargs. - eapply map_eq_inj in Hargs. + eapply map_eq_inj in Hargs. apply (nth_error_all hnth Hargs). * rewrite nth_error_map. destruct nth_error eqn:hnth; auto. @@ -1862,7 +1862,7 @@ Section Rho. (rewrite Upn_comp ?map_length ?fix_subst_length ?map_length //; try now autorewrite with len); []. apply subst_consn_proper => //. - rewrite map_cofix_subst' //. + rewrite map_cofix_subst' //. intros n0. simpl. now rewrite up_Upn. rewrite !map_map_compose. unfold cofix_subst. generalize #|mfix|. @@ -1903,8 +1903,8 @@ Section Rho. clear. generalize #|m|. induction m using rev_ind. simpl. constructor. intros. rewrite map_app !fold_fix_context_app. simpl. constructor. simpl. reflexivity. apply IHm; eauto. Qed. - - Lemma rho_lift0 Γ Δ P t : + + Lemma rho_lift0 Γ Δ P t : on_free_vars P t -> lift0 #|Δ| (rho Γ t) = rho (Γ ,,, Δ) (lift0 #|Δ| t). Proof using wfΣ. @@ -1988,7 +1988,7 @@ Section Rho. fix_context (map_fix rho Γ (rho_ctx_over Γ (fix_context mfix)) mfix) = rho_ctx_over Γ (fix_context mfix). Proof using wfΣ. - intros hm. + intros hm. rewrite - (fix_context_fold p) //. unfold map_fix. f_equal. f_equal. f_equal. rewrite (fix_context_fold p) //. @@ -2102,8 +2102,8 @@ Section Rho. forall (Γ Γ' Γ'0 : context) (args0 args1 : list term), pred1_ctx Σ Γ Γ' -> pred1_ctx Σ Γ' Γ'0 -> - All2 (fun x y => - (pred1 Σ Γ Γ' x y * + All2 (fun x y => + (pred1 Σ Γ Γ' x y * ((on_ctx_free_vars xpredT Γ -> on_free_vars xpredT x -> forall Γ'0, pred1_ctx Σ Γ' Γ'0 -> @@ -2127,7 +2127,7 @@ Section Rho. rewrite decompose_app_mkApps //. Qed. - Lemma is_constructor_pred1 Γ Γ' n l l' : + Lemma is_constructor_pred1 Γ Γ' n l l' : All2 (pred1 Σ Γ Γ') l l' -> is_constructor n l -> is_constructor n l'. Proof using Type. @@ -2137,21 +2137,21 @@ Section Rho. now eapply isConstruct_app_pred1. eapply IHX. Qed. - + Ltac inv_on_free_vars ::= match goal with - | [ H : is_true (on_free_vars ?P ?t) |- _ ] => + | [ H : is_true (on_free_vars ?P ?t) |- _ ] => progress (cbn in H || rewrite -> on_free_vars_mkApps in H); - (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || + (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || eapply forallb_All in H); intros - | [ H : is_true (test_def (on_free_vars ?P) ?Q ?x) |- _ ] => - let H0 := fresh in let H' := fresh in - move/andP: H => [H0 H']; + | [ H : is_true (test_def (on_free_vars ?P) ?Q ?x) |- _ ] => + let H0 := fresh in let H' := fresh in + move/andP: H => [H0 H']; try rewrite -> shiftnP_xpredT in H0; try rewrite -> shiftnP_xpredT in H'; intros end. - Lemma pred1_on_free_vars_mfix_ind Γ Γ' P mfix0 mfix1 : + Lemma pred1_on_free_vars_mfix_ind Γ Γ' P mfix0 mfix1 : on_ctx_free_vars P Γ -> All (fun x : def term => test_def (on_free_vars P) (on_free_vars (shiftnP #|mfix0| P)) x) mfix0 -> All2_prop2_eq Γ Γ' (Γ,,, fix_context mfix0) (Γ',,, fix_context mfix1) @@ -2174,29 +2174,29 @@ Section Rho. Lemma pred1_on_free_vars_gen : (forall Γ Γ' t u, pred1 Σ Γ Γ' t u -> - forall P, + forall P, on_ctx_free_vars P Γ -> on_free_vars P t -> on_free_vars P u) × (forall Γ Γ' Δ Δ', pred1_ctx Σ Γ Γ' -> pred1_ctx_over Σ Γ Γ' Δ Δ' -> - forall P, + forall P, on_ctx_free_vars P (Γ ,,, Δ) -> on_ctx_free_vars P (Γ' ,,, Δ')). Proof using wfΣ. set Pctx := - fun (Γ Δ : context) => + fun (Γ Δ : context) => forall P, on_ctx_free_vars P Γ -> on_ctx_free_vars P Δ. - set Pctxover := - fun (Γ Γ' Δ Δ' : context) => + set Pctxover := + fun (Γ Γ' Δ Δ' : context) => forall P, on_ctx_free_vars P (Γ ,,, Δ) -> on_ctx_free_vars P (Γ' ,,, Δ'). - Ltac IHs := + Ltac IHs := match goal with - [ H : forall P, is_true (on_ctx_free_vars P ?Γ) -> is_true (on_free_vars P ?t) -> _, - H' : is_true (on_ctx_free_vars _ ?Γ), + [ H : forall P, is_true (on_ctx_free_vars P ?Γ) -> is_true (on_free_vars P ?t) -> _, + H' : is_true (on_ctx_free_vars _ ?Γ), H'' : is_true (on_free_vars _ ?t) |- _ ] => specialize (H _ H' H'') end. @@ -2234,7 +2234,7 @@ Section Rho. setoid_rewrite Nat.add_succ_r in i0. eauto with fvs. } now specialize (IHX0 P (S n) HΓ). - + - move: H0. rewrite !on_ctx_free_vars_app. move/andP=> [] onΔ onΓ. specialize (H _ onΓ). @@ -2290,7 +2290,7 @@ Section Rho. - move/and3P: H3 => [] ond0 ont0 onb0; t. eapply on_free_vars_subst; cbn; t. - - specialize (H _ H1). + - specialize (H _ H1). rewrite on_free_vars_lift0 //. change P with (addnP 0 P) in H. destruct nth_error eqn:hnth => //. @@ -2307,14 +2307,14 @@ Section Rho. eapply All2_nth_error_Some_right in X2 as [t' [hnth [? [[? ?] ?]]]]; tea. eapply nth_error_forallb in hbrs; tea. cbn in hbrs. move/andP: hbrs => [] hctx' hbody. - rewrite skipn_length; try lia. rewrite H1. + rewrite skipn_length; try lia. rewrite H1. replace (ci_npar ci + context_assumptions (bcontext br) - ci_npar ci) - with (context_assumptions (bcontext br)) by lia. + with (context_assumptions (bcontext br)) by lia. eapply on_free_vars_expand_lets_k. now len. eapply on_free_vars_ctx_inst_case_context; trea; len; eauto with fvs. solve_all. - rewrite -e. + rewrite -e. now rewrite -(All2_length X1). len. eapply i0. rewrite /inst_case_branch_context. rewrite -e; t. now rewrite -e. @@ -2336,7 +2336,7 @@ Section Rho. eapply (on_free_vars_fix_subst _ _ idx). cbn => //. len. eapply nth_error_forallb in H4; tea. now move/andP: H4 => []. - + - move/and4P: H7 => [] => onpars onpret onctx /andP[] onargs onbrs. inv_on_free_vars. cbn in a. assert (on_ctx_free_vars (shiftnP #|p0.(pcontext)| P) (Γ,,, PCUICCases.inst_case_predicate_context p0)). @@ -2395,7 +2395,7 @@ Section Rho. intros p onΓ ont. now move: (fst pred1_on_free_vars_gen _ _ _ _ p P onΓ ont). Qed. - + Lemma pred1_on_ctx_free_vars {P Γ Γ'} : pred1_ctx Σ Γ Γ' -> on_ctx_free_vars P Γ -> @@ -2428,7 +2428,7 @@ Section Rho. now apply (snd pred1_on_free_vars_gen _ _ _ _ p p' P). Qed. - Lemma on_free_vars_subst_consn P s x : + Lemma on_free_vars_subst_consn P s x : forallb (on_free_vars P) s -> on_free_vars xpredT ((s ⋅n ids) x). Proof using Type. @@ -2437,11 +2437,11 @@ Section Rho. eapply nth_error_forallb in hs; tea; cbn in *. eapply on_free_vars_impl; tea => //. Qed. - + Hint Resolve pred1_on_free_vars pred1_on_ctx_free_vars : fvs. - Lemma pred1_on_free_vars_mfix Γ Γ' P mfix0 mfix1 : + Lemma pred1_on_free_vars_mfix Γ Γ' P mfix0 mfix1 : on_ctx_free_vars P Γ -> All (fun x : def term => test_def (on_free_vars P) (on_free_vars (shiftnP #|mfix0| P)) x) mfix0 -> All2_prop2_eq Γ Γ' (Γ,,, fix_context mfix0) (Γ',,, fix_context mfix1) @@ -2468,7 +2468,7 @@ Section Rho. Lemma pred_subst_rho_cofix (Γ Γ' rΓ : context) (mfix0 mfix1 : mfixpoint term) idx : on_free_vars xpredT (tCoFix mfix0 idx) -> on_ctx_free_vars xpredT Γ -> - pred1_ctx Σ Γ Γ' -> pred1_ctx Σ Γ' rΓ -> + pred1_ctx Σ Γ Γ' -> pred1_ctx Σ Γ' rΓ -> pred1_ctx_over Σ Γ' rΓ (fix_context mfix1) (rho_ctx_over rΓ (fix_context mfix0)) -> All2 (on_Trel eq (fun x : def term => (dname x, rarg x))) @@ -2490,8 +2490,8 @@ Section Rho. (rΓ ,,, rho_ctx_over rΓ (fix_context mfix0)) y (rho (rΓ ,,, rho_ctx_over rΓ (fix_context mfix0)) x)) dbody) mfix0 mfix1 - -> pred1_subst (Σ := Σ) xpredT xpredT (Γ' ,,, fix_context mfix1) - (rΓ ,,, rho_ctx_over rΓ (fix_context mfix0)) Γ' rΓ + -> pred1_subst (Σ := Σ) xpredT xpredT (Γ' ,,, fix_context mfix1) + (rΓ ,,, rho_ctx_over rΓ (fix_context mfix0)) Γ' rΓ (cofix_subst mfix1 ⋅n ids) (cofix_subst (map_fix rho rΓ (rho_ctx_over rΓ (fix_context mfix0)) mfix0) ⋅n ids). Proof using wfΣ. @@ -2507,7 +2507,7 @@ Section Rho. unfold on_Trel in *; solve_all. eapply All2_mix => //. clear redr. solve_all. unfold on_Trel in *; solve_all. } - split. + split. destruct (leb_spec_Set (S x) #|cofix_subst mfix1|). 2:{ len in l; rewrite !subst_consn_ge //; len; try lia. all:rewrite (All2_length redl) //. lia. @@ -2565,7 +2565,7 @@ Section Rho. Lemma pred_subst_rho_fix (Γ Γ' rΓ : context) (mfix0 mfix1 : mfixpoint term) idx : on_free_vars xpredT (tCoFix mfix0 idx) -> on_ctx_free_vars xpredT Γ -> - pred1_ctx Σ Γ Γ' -> pred1_ctx Σ Γ' rΓ -> + pred1_ctx Σ Γ Γ' -> pred1_ctx Σ Γ' rΓ -> pred1_ctx_over Σ Γ' rΓ (fix_context mfix1) (rho_ctx_over rΓ (fix_context mfix0)) -> All2 (on_Trel eq (fun x : def term => (dname x, rarg x))) @@ -2587,8 +2587,8 @@ Section Rho. (rΓ ,,, rho_ctx_over rΓ (fix_context mfix0)) y (rho (rΓ ,,, rho_ctx_over rΓ (fix_context mfix0)) x)) dbody) mfix0 mfix1 - -> pred1_subst (Σ := Σ) xpredT xpredT (Γ' ,,, fix_context mfix1) - (rΓ ,,, rho_ctx_over rΓ (fix_context mfix0)) Γ' rΓ + -> pred1_subst (Σ := Σ) xpredT xpredT (Γ' ,,, fix_context mfix1) + (rΓ ,,, rho_ctx_over rΓ (fix_context mfix0)) Γ' rΓ (fix_subst mfix1 ⋅n ids) (fix_subst (map_fix rho rΓ (rho_ctx_over rΓ (fix_context mfix0)) mfix0) ⋅n ids). Proof using wfΣ. @@ -2604,7 +2604,7 @@ Section Rho. unfold on_Trel in *; solve_all. eapply All2_mix => //. clear redr. solve_all. unfold on_Trel in *; solve_all. } - split. + split. destruct (leb_spec_Set (S x) #|fix_subst mfix1|). 2:{ len in l; rewrite !subst_consn_ge //; len; try lia. all:rewrite (All2_length redl) //. lia. @@ -2769,7 +2769,7 @@ Section Rho. eapply All_All2_telescopei_gen; tea. now len. eapply All2_map_right; solve_all. Qed. - + Lemma All_All2_telescopei p (Γ Γ' : context) (m m' : mfixpoint term) : on_ctx_free_vars p Γ -> forallb (test_def (on_free_vars p) (on_free_vars (shiftnP #|m| p))) m -> @@ -2836,7 +2836,7 @@ Section Rho. eapply All2_telescope_mapi. eapply All_All2_telescopei; eauto. Qed. - + Lemma pred1_rho_fix_context_2 p (Γ Γ' : context) (m m' : mfixpoint term) : on_ctx_free_vars p Γ' -> forallb (test_def (on_free_vars p) (on_free_vars (shiftnP #|m| p))) m -> @@ -2852,7 +2852,7 @@ Section Rho. eapply pred1_fix_context; tea. Qed. - + (* Lemma substitution_pred1 Γ Δ Γ' Δ' s s' N N' : psubst Σ Γ Γ' s s' Δ Δ' -> pred1 Σ (Γ ,,, Δ) (Γ' ,,, Δ') N N' -> @@ -2906,14 +2906,14 @@ Section Rho. Qed. Hint Rewrite decompose_app_inst using auto : lift. - Lemma All2_fold_context_assumptions {P} {Γ Δ} : + Lemma All2_fold_context_assumptions {P} {Γ Δ} : All2_fold (on_decls P) Γ Δ -> context_assumptions Γ = context_assumptions Δ. Proof using Type. induction 1; simpl; auto. depelim p => /=; now auto using f_equal. Qed. - - Lemma pred1_subst_consn {Δ Δ' Γ Γ' args0 args1} : + + Lemma pred1_subst_consn {Δ Δ' Γ Γ' args0 args1} : pred1_ctx Σ Γ' Γ -> on_ctx_free_vars xpredT Γ' -> forallb (on_free_vars xpredT) args1 -> @@ -2960,9 +2960,9 @@ Section Rho. econstructor; tea. congruence. Qed. (* - Lemma pred1_subst_shiftn {Δ Δ' Γ Γ' n s s'} : + Lemma pred1_subst_shiftn {Δ Δ' Γ Γ' n s s'} : n = #|Δ'| -> - pred1_subst (Δ ,,, Δ') Γ Γ' s s' -> + pred1_subst (Δ ,,, Δ') Γ Γ' s s' -> pred1_subst Δ Γ Γ' (↑^n ∘s s) (↑^n ∘s s'). Proof. intros hn Hp i. @@ -2986,11 +2986,11 @@ Section Rho. destruct decl_body => //. Qed. - Lemma pred1_subst_skipn {Δ Δ' Γ Γ' n s s'} : + Lemma pred1_subst_skipn {Δ Δ' Γ Γ' n s s'} : #|s| = #|s'| -> #|Δ'| = n -> pred1_ctx Σ Γ Γ' -> - pred1_subst (Δ ,,, Δ') Γ Γ' (s ⋅n ids) (s' ⋅n ids) -> + pred1_subst (Δ ,,, Δ') Γ Γ' (s ⋅n ids) (s' ⋅n ids) -> pred1_subst Δ Γ Γ' (skipn n s ⋅n ids) (skipn n s' ⋅n ids). Proof. intros. @@ -3024,7 +3024,7 @@ Section Rho. lia_f_equal. Qed. *) - Lemma context_assumptions_smash_context' acc Γ : + Lemma context_assumptions_smash_context' acc Γ : context_assumptions (smash_context acc Γ) = #|smash_context [] Γ| + context_assumptions acc. Proof using Type. @@ -3032,7 +3032,7 @@ Section Rho. rewrite context_assumptions_smash_context; now len. Qed. - Lemma context_assumptions_smash_context'' Γ : + Lemma context_assumptions_smash_context'' Γ : context_assumptions (smash_context [] Γ) = #|smash_context [] Γ|. Proof using Type. rewrite context_assumptions_smash_context' /=; lia. @@ -3050,14 +3050,14 @@ Section Rho. Proof using Type. now intros -> ->. Qed. - + Lemma pred1_expand_lets (Γ Γ' Δ Δ' : context) b b' : on_ctx_free_vars xpredT Γ -> on_ctx_free_vars xpredT Δ -> on_free_vars xpredT b -> pred1 Σ (Γ ,,, Δ) (Γ' ,,, Δ') b b' -> #|Γ| = #|Γ'| -> - pred1 Σ (Γ ,,, smash_context [] Δ) (Γ' ,,, smash_context [] Δ') + pred1 Σ (Γ ,,, smash_context [] Δ) (Γ' ,,, smash_context [] Δ') (expand_lets Δ b) (expand_lets Δ' b'). Proof using wfΣ. intros onΓ onΔ onb pred hlen. @@ -3115,7 +3115,7 @@ Section Rho. Lemma fold_context_cst (ctx : context) : ctx = fold_context (fun _ d => map_decl id d) ctx. Proof using Type. - induction ctx; simpl; auto. + induction ctx; simpl; auto. now rewrite -IHctx map_decl_id. Qed. @@ -3131,7 +3131,7 @@ Section Rho. now move/andP: H => /= []. Qed. - Lemma on_ctx_free_vars_xpredT_snoc d Γ : + Lemma on_ctx_free_vars_xpredT_snoc d Γ : on_ctx_free_vars xpredT (d :: Γ) = on_ctx_free_vars xpredT Γ && on_free_vars_decl xpredT d. Proof using Type. @@ -3144,7 +3144,7 @@ Section Rho. Hint Extern 3 (is_true (_ && _)) => apply/andP; idtac : fvs. - Lemma on_ctx_free_vars_xpredT_skipn Γ n : + Lemma on_ctx_free_vars_xpredT_skipn Γ n : on_ctx_free_vars xpredT Γ -> on_ctx_free_vars xpredT (skipn n Γ). Proof using Type. @@ -3160,8 +3160,8 @@ Section Rho. induction Δ as [|[na [b|] ty] Δ]; constructor; auto. all:constructor; apply pred1_refl_gen, All2_fold_app => //. Qed. - - Definition fake_params n : context := + + Definition fake_params n : context := unfold n (fun x => {| decl_name := {| binder_name := nAnon; binder_relevance := Relevant |}; decl_body := None; decl_type := tSort Universe.type0 |}). @@ -3173,14 +3173,14 @@ Section Rho. len. now rewrite IHn. Qed. Hint Rewrite context_assumptions_fake_params : len. - + Lemma pred1_ctx_over_inst_case_context Γ Γ' pars pars' puinst pctx : pred1_ctx Σ Γ Γ' -> on_ctx_free_vars xpredT Γ -> forallb (on_free_vars xpredT) pars -> on_free_vars_ctx (shiftnP #|pars| xpredT) pctx -> All2 (pred1 Σ Γ Γ') pars pars' -> - pred1_ctx_over Σ Γ Γ' + pred1_ctx_over Σ Γ Γ' (inst_case_context pars puinst pctx) (inst_case_context pars' puinst pctx). Proof using wfΣ. @@ -3200,7 +3200,7 @@ Section Rho. rewrite on_free_vars_ctx_subst_instance; tea. now rewrite -> shiftnP_xpredT in onpctx. erewrite <- on_free_vars_ctx_on_ctx_free_vars. - erewrite shiftnP_xpredT => //. + erewrite shiftnP_xpredT => //. rewrite -subst_context0_inst_context. eapply on_free_vars_ctx_on_ctx_free_vars_xpredT. eapply on_free_vars_ctx_subst_context_xpredT => //. @@ -3224,7 +3224,7 @@ Section Rho. on_free_vars xpredT x -> forall rΓ, pred1_ctx Σ Γ' rΓ -> pred1 Σ Γ' rΓ y (rho rΓ x))) pars pars' -> - pred1_ctx_over Σ Γ' rΓ + pred1_ctx_over Σ Γ' rΓ (inst_case_context pars' puinst pctx) (inst_case_context (map (rho rΓ) pars) puinst pctx). Proof using wfΣ. @@ -3234,7 +3234,7 @@ Section Rho. now rewrite -(All2_length a). eapply All2_map_right, All2_sym; solve_all. Qed. - + Ltac my_rename_hyp h th := match th with | pred1 _ _ _ ?b _ => fresh "pred" b @@ -3243,7 +3243,7 @@ Section Rho. end. Ltac rename_hyp h ht ::= my_rename_hyp h ht. - + Lemma All2_fold_fold_context_right P f (ctx ctx' : context) : All2_fold (fun Γ Γ' d d' => P Γ (fold_context_term f Γ') d (map_decl (f (fold_context_term f Γ')) d')) ctx ctx' -> All2_fold P ctx (fold_context_term f ctx'). @@ -3264,21 +3264,21 @@ Section Rho. on_free_vars xpredT t -> forall Γ', pred1_ctx Σ Δ Γ' -> pred1 Σ Δ Γ' u (rho Γ' t)) × - (forall Γ Γ' Δ Δ', + (forall Γ Γ' Δ Δ', pred1_ctx Σ Γ Γ' -> pred1_ctx_over Σ Γ Γ' Δ Δ' -> on_ctx_free_vars xpredT (Γ ,,, Δ) -> - forall Γ'0, pred1_ctx Σ Γ' Γ'0 -> + forall Γ'0, pred1_ctx Σ Γ' Γ'0 -> pred1_ctx_over Σ Γ' Γ'0 Δ' (rho_ctx_over Γ'0 Δ)). Proof using wfΣ with solve_discr. - set Pctx := fun (Γ Δ : context) => + set Pctx := fun (Γ Δ : context) => on_ctx_free_vars xpredT Γ -> - pred1_ctx Σ Δ (rho_ctx Γ). + pred1_ctx Σ Δ (rho_ctx Γ). refine (pred1_ind_all_ctx Σ _ Pctx _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); subst Pctx; intros *. all:try intros **; rename_all_hyps; try solve [specialize (forall_Γ _ X3); eauto]; eauto; - try solve [simpl; econstructor; simpl; eauto]; repeat inv_on_free_vars; + try solve [simpl; econstructor; simpl; eauto]; repeat inv_on_free_vars; try rewrite -> shiftnP_xpredT in *; eauto. - cbn in *. simpl. @@ -3303,8 +3303,8 @@ Section Rho. pose proof (pred1_pred1_ctx _ predt0). eapply (substitution0_pred1); simpl in *; eauto; rtoProp; eauto with fvs. eapply impl_impl_forall_Γ'; eauto with fvs. - constructor; eauto. constructor. eauto with fvs. - + constructor; eauto. constructor. eauto with fvs. + - simp rho. pose proof (pred1_pred1_ctx _ predt0). eapply (substitution0_let_pred1); simpl in *; eauto with fvs. @@ -3362,9 +3362,9 @@ Section Rho. intuition. forward X3. now rewrite -> shiftnP_xpredT in clbod. pose proof (All2_length X1). - rewrite H. rewrite heq_length. + rewrite H. rewrite heq_length. replace (ci_npar ci + context_assumptions (bcontext br) - ci_npar ci) - with (context_assumptions (bcontext br)) by lia. + with (context_assumptions (bcontext br)) by lia. rewrite breq eqb_refl. rewrite !subst_inst. assert (forallb (on_free_vars xpredT) args1). @@ -3405,7 +3405,7 @@ Section Rho. now len. + rewrite -subst_inst. eapply on_free_vars_subst. rewrite forallb_rev forallb_skipn //; tea. - eapply on_free_vars_expand_lets_k => //. len. + eapply on_free_vars_expand_lets_k => //. len. rewrite skipn_length; lia. rewrite /inst_case_branch_context. eapply on_free_vars_ctx_inst_case_context; trea; len; solve_all. eauto with fvs. @@ -3419,7 +3419,7 @@ Section Rho. eapply All2_rev in X1. eapply pred1_subst_consn; tea. eauto with fvs. rewrite forallb_rev forallb_skipn //. len. rewrite !List.skipn_length; lia. - len. rewrite breq List.skipn_length H heq_length. lia. + len. rewrite breq List.skipn_length H heq_length. lia. len. congruence. - (* Fix reduction *) @@ -3429,7 +3429,7 @@ Section Rho. assert (on_free_vars xpredT (tFix mfix1 idx)). { eapply All2_All_mix_left in X3; tea. cbn. eapply All_forallb. eapply All2_All_right; tea. cbn. - intuition auto. destruct a1. + intuition auto. destruct a1. move/andP: a0 => [] onty onb. rewrite -> shiftnP_xpredT in onb. apply/andP; split; eauto with fvs. @@ -3500,7 +3500,7 @@ Section Rho. rewrite on_ctx_free_vars_xpredT. eapply on_free_vars_ctx_inst_case_context; trea. } forward impl_forall_Γ'1 by tas. - intuition auto. + intuition auto. assert (predctx : pred1_ctx_over Σ Γ' Γ'0 (PCUICCases.inst_case_predicate_context p1) (PCUICCases.inst_case_predicate_context (rho_predicate Γ'0 p0))). @@ -3510,7 +3510,7 @@ Section Rho. rewrite test_context_k_closed_on_free_vars_ctx in p3. eapply on_free_vars_ctx_impl; tea; eauto. intros i. rewrite /shiftnP /closedP. destruct Nat.ltb => //. } - + eapply pred_case; simpl; eauto. * eapply All2_sym, All2_map_left. solve_all. * apply X2, All2_fold_app => //. @@ -3565,12 +3565,12 @@ Section Rho. eapply (All2_impl a1); solve_all. inv_on_free_vars. solve_all. unfold on_Trel in *; solve_all. solve_all. unfold on_Trel in *; solve_all. inv_on_free_vars. - eapply X3; eauto with fvs. + eapply X3; eauto with fvs. eapply on_contexts_app => //. eapply X0 => //. + eapply forallb_All in b. eapply All2_All_mix_left in X4; tea. eapply All2_sym, All2_map_left, All2_impl; eauto. simpl. intuition eauto. - + - (* Proj-Cofix reduction *) simpl. cbn in H1; inv_on_free_vars. cbn in a. assert (on_ctx_free_vars xpredT (Γ,,, fix_context mfix0)). @@ -3606,7 +3606,7 @@ Section Rho. eapply on_free_vars_subst; eauto with fvs. eapply (on_free_vars_cofix_subst _ _ idx); eauto with fvs. rewrite shiftnP_xpredT //. - + rewrite -(rho_cofix_subst xpredT) //. + + rewrite -(rho_cofix_subst xpredT) //. red in X3. eapply (pred_subst_rho_cofix Γ _ _ _ _ idx) => //; solve_all; unfold on_Trel in *; eauto with fvs. inv_on_free_vars. solve_all. inv_on_free_vars. solve_all. eapply X6; eauto with fvs. @@ -3623,16 +3623,16 @@ Section Rho. destruct g. 2:{ constructor; auto. } destruct c0. destruct cst_body0 eqn:Heq'. pcuic. constructor; auto. - + - simpl in *. inv_on_free_vars. rewrite rho_app_proj. rewrite decompose_app_mkApps; auto. change eq_inductive with (@eqb inductive _). case: eqb_specT => // => _. eapply All2_nth_error_Some_right in heq_nth_error as [t' [? ?]]; eauto. simpl in y. rewrite e. simpl. - auto. eapply y => //. + auto. eapply y => //. eapply nth_error_forallb in b; tea. - + - simpl; simp rho. eapply pred_abs; auto. eapply impl_impl_forall_Γ'0; eauto with fvs. constructor; eauto with fvs. constructor; eauto with fvs. @@ -3654,7 +3654,7 @@ Section Rho. apply on_free_vars_fix_context. solve_all. } destruct (rho_fix_elim Γ'0 mfix i l). - * rewrite /unfold_fix {1}/map_fix nth_error_map e /=. + * rewrite /unfold_fix {1}/map_fix nth_error_map e /=. eapply (is_constructor_app_ge (rarg d) _ _) in i0 => //. rewrite -> i0. rewrite map_app !mkApps_app. @@ -3713,7 +3713,7 @@ Section Rho. move: i1. eapply is_constructor_pred1. eapply All2_app; eauto. - eapply All2_app => //. repeat constructor; auto. + eapply All2_app => //. repeat constructor; auto. ** (* None reduce *) simpl. rewrite map_app. @@ -3731,19 +3731,19 @@ Section Rho. rewrite rho_app_lambda' in X1. inv_on_free_vars. destruct l. simpl in *. depelim predM0; solve_discr. - simp rho in X1. + simp rho in X1. depelim X1... econstructor; eauto. simpl. simp rho. rewrite map_app mkApps_app. constructor; eauto. - + + (* No head redex *) simpl. constructor; auto. - simpl; simp rho; simpl. eapply pred_zeta; eauto with fvs. eapply impl_impl_forall_Γ'1; eauto with fvs. do 2 (constructor; eauto with fvs). - + - (* Case reduction *) rewrite rho_app_case. have hpars : (All2 (pred1 Σ Γ' Γ'0) (pparams p1) @@ -3752,7 +3752,7 @@ Section Rho. have hbrs : All2 (fun br br' : branch term => on_Trel_eq (pred1 Σ (Γ',,, inst_case_branch_context p1 br) - (Γ'0,,, inst_case_branch_context (rho_predicate Γ'0 p0) br')) bbody bcontext br br') brs1 + (Γ'0,,, inst_case_branch_context (rho_predicate Γ'0 p0) br')) bbody bcontext br br') brs1 (map (rho_br Γ'0 (rho_predicate Γ'0 p0)) brs0). { eapply All2_sym, All2_map_left; solve_all. assert (on_ctx_free_vars xpredT (Γ,,, inst_case_branch_context p0 x)). @@ -3772,7 +3772,7 @@ Section Rho. eapply on_free_vars_ctx_impl; tea; eauto. intros i. rewrite /shiftnP /closedP. destruct Nat.ltb => //. solve_all. } eapply on_contexts_app => //. } - have pred_pred_ctx : + have pred_pred_ctx : pred1_ctx_over Σ Γ' Γ'0 (PCUICCases.inst_case_predicate_context p1) (PCUICCases.inst_case_predicate_context (rho_predicate Γ'0 p0)). { rewrite /PCUICCases.inst_case_predicate_context /=. @@ -3785,13 +3785,13 @@ Section Rho. { rewrite on_ctx_free_vars_app addnP_xpredT H1 andb_true_r. eapply on_free_vars_ctx_on_ctx_free_vars_xpredT. eapply on_free_vars_ctx_inst_case_context; trea; solve_all. } - destruct (decompose_app c0) eqn:Heq. cbn -[eqb]. + destruct (decompose_app c0) eqn:Heq. cbn -[eqb]. eapply on_contexts_over_app in pred_pred_ctx. specialize (impl_impl_forall_Γ' H p2 _ pred_pred_ctx) as Hpret. specialize (impl_forall_Γ'0 H _ predΓ'0) as Hpctx. specialize (impl_impl_forall_Γ'0 H1 p4 _ predΓ'0) as Hc. destruct (construct_cofix_discr t) eqn:Heq'. - + destruct t; noconf Heq'. + (* Iota *) apply decompose_app_inv in Heq. @@ -3836,7 +3836,7 @@ Section Rho. eapply pred1_pred1_ctx in a. eapply on_contexts_app_inv => //. apply (All2_fold_length predΓ'0). simp rho in Hc. - + + (* CoFix *) apply decompose_app_inv in Heq. subst c0. simpl. simp rho. @@ -3863,18 +3863,18 @@ Section Rho. { eapply All2_impl; [eapply b0|]; pcuic. } pose proof (All2_mix a1 X0). eapply pred1_rho_fix_context_2 in X7; eauto with fvs. - + rewrite - (fold_fix_context_rho_ctx xpredT) // in X7. rewrite (fix_context_map_fix xpredT) // in X7. eapply rho_All_All2_fold_inv in X7; pcuic. rewrite /rho_fix_context - (fold_fix_context_rho_ctx xpredT) // in a1. - + eapply on_contexts_app_inv in pred_pred_ctx as []. 2:eapply (All2_fold_length predΓ'0). destruct nth_error eqn:Heq. simpl. * (* CoFix unfolding *) pose proof Heq. eapply All2_nth_error_Some in Heq; eauto. destruct Heq; intuition auto. - eapply pred_cofix_case with + eapply pred_cofix_case with (map_fix rho Γ'0 (rho_ctx_over Γ'0 (fix_context mfix)) mfix) (rarg d); pcuic. -- rewrite (fix_context_map_fix xpredT) //. @@ -3900,7 +3900,7 @@ Section Rho. eapply on_contexts_app_inv => //. now eapply pred1_pred1_ctx in X8. apply (All2_fold_length predΓ'0). - + * eapply pred_case; simpl; eauto; solve_all. eapply All2_map_right_inv in hbrs. solve_all. eapply pred1_pred1_ctx in a4. eapply on_contexts_app_inv in a4 as [] => //. @@ -3912,13 +3912,13 @@ Section Rho. eapply All2_fold_impl; tea. solve_all. eapply All_decls_map_right. eapply All_decls_impl; tea. solve_all. - + --- eapply All2_mix; pcuic. eapply All2_prod_inv in a1 as []. rewrite /rho_fix_context -(fold_fix_context_rho_ctx xpredT) //. solve_all. eapply All2_mix; pcuic. --- pcuic. - + + apply decompose_app_inv in Heq. subst c0. rewrite construct_cofix_discr_match //. econstructor; cbn; tea; auto. @@ -3957,7 +3957,7 @@ Section Rho. constructor; auto. eapply pred_mkApps; auto. econstructor; eauto. - + + apply decompose_app_inv in Heq. subst c. simpl. simp rho in Hc |- *. @@ -4009,7 +4009,7 @@ Section Rho. rewrite nth_error_map. rewrite H1. simpl. f_equal. f_equal. unfold map_fix. - rewrite (fold_fix_context_rho_ctx xpredT) //. + rewrite (fold_fix_context_rho_ctx xpredT) //. rewrite (map_cofix_subst _ (fun Γ Γ' => rho (Γ ,,, Γ'))) //. intros. simp rho; simpl; simp rho. reflexivity. @@ -4035,7 +4035,7 @@ Section Rho. eapply All2_All_mix_left in X3; tea; eapply All2_impl; tea. unfold on_Trel. intros; cbn; intuition auto; inv_on_free_vars; eauto with fvs. rewrite (fix_context_map_fix xpredT) //; solve_all. - eapply X2. + eapply X2. eapply on_contexts_app => //. - simp rho; simpl; simp rho. diff --git a/pcuic/theories/PCUICPrincipality.v b/pcuic/theories/PCUICPrincipality.v index 31c6a3894..875105cfb 100644 --- a/pcuic/theories/PCUICPrincipality.v +++ b/pcuic/theories/PCUICPrincipality.v @@ -5,8 +5,8 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction PCUICWeakeningEnvTyp PCUICSubstitution PCUICEquality PCUICReduction PCUICCumulativity PCUICConfluence PCUICClosed PCUICClosedTyp PCUICContextConversion PCUICContextConversionTyp PCUICConversion PCUICInversion PCUICUnivSubst - PCUICArities PCUICValidity PCUICInductives PCUICInductiveInversion - PCUICSR PCUICCumulProp PCUICWfUniverses + PCUICArities PCUICValidity PCUICInductives PCUICInductiveInversion + PCUICSR PCUICCumulProp PCUICWfUniverses PCUICOnFreeVars PCUICWellScopedCumulativity. Require Import ssreflect ssrbool. @@ -69,7 +69,7 @@ Section Principality. Ltac int inv := intros B hB; eapply inv in hB; auto; split; [|econstructor; eauto]. Hint Resolve wf_ext_wf : core. - + Theorem principal_type {Γ u A} : Σ ;;; Γ |- u : A -> ∑ C, (forall B, Σ ;;; Γ |- u : B -> Σ ;;; Γ ⊢ C ≤ B × Σ ;;; Γ |- u : C). Proof using wfΣ. @@ -191,7 +191,7 @@ Section Principality. eexists; int inversion_Const. destruct hB as [decl' [wf [declc' [cu cum]]]]. now rewrite -(declared_constant_inj _ _ d declc') in cum. - + - eapply inversion_Ind in hA as [mdecl [idecl [? [Hdecl ?]]]] => //; auto. repeat outtimes. exists (subst_instance u (ind_type idecl)). @@ -236,7 +236,7 @@ Section Principality. etransitivity; [|tea]. eapply ws_cumul_pb_mkApps; auto. rewrite /ptm /predctx. * eapply PCUICGeneration.type_it_mkLambda_or_LetIn in pret_ty. - eapply ws_cumul_pb_eq_le, wt_cumul_pb_refl. eapply pret_ty. + eapply ws_cumul_pb_eq_le, wt_cumul_pb_refl. eapply pret_ty. * eapply All2_app. 2:constructor; auto. assert (ws_cumul_pb_terms Σ Γ (pparams p ++ indices) (pparams p ++ indices')). { transitivity x9'; tea. transitivity x0' => //. now symmetry. } @@ -355,11 +355,11 @@ End Principality. Lemma principal_type_ind {cf:checker_flags} {Σ Γ c ind u u' args args'} {wfΣ: wf_ext Σ} : Σ ;;; Γ |- c : mkApps (tInd ind u) args -> Σ ;;; Γ |- c : mkApps (tInd ind u') args' -> - (∑ ui', + (∑ ui', PCUICEquality.R_global_instance Σ.1 (eq_universe (global_ext_constraints Σ)) - (leq_universe (global_ext_constraints Σ)) (IndRef ind) #|args| ui' u * + (leq_universe (global_ext_constraints Σ)) (IndRef ind) #|args| ui' u * PCUICEquality.R_global_instance Σ.1 (eq_universe (global_ext_constraints Σ)) - (leq_universe (global_ext_constraints Σ)) (IndRef ind) #|args'| ui' u') * + (leq_universe (global_ext_constraints Σ)) (IndRef ind) #|args'| ui' u') * ws_cumul_pb_terms Σ Γ args args'. Proof. intros h h'. @@ -380,7 +380,7 @@ Proof. transitivity l''. symmetry. auto using red_terms_ws_cumul_pb_terms. now symmetry. Qed. - + Lemma eq_term_leq_term {cf:checker_flags} {Σ : global_env_ext} {x y} : eq_term Σ Σ x y -> leq_term Σ Σ x y. @@ -424,9 +424,9 @@ Notation eq_term_napp Σ n x y := Notation leq_term_napp Σ n x y := (eq_term_upto_univ_napp Σ (eq_universe Σ) (leq_universe Σ) n x y). - + Lemma eq_term_upto_univ_napp_leq {cf:checker_flags} {Σ : global_env_ext} {n x y} : - eq_term_napp Σ n x y -> + eq_term_napp Σ n x y -> leq_term_napp Σ n x y. Proof. eapply eq_term_upto_univ_impl; auto; typeclasses eauto. @@ -454,19 +454,19 @@ Proof. intros. now eapply eq_term_empty_eq_term. Qed. -Lemma typing_leq_term {cf:checker_flags} (Σ : global_env_ext) Γ t t' T T' : +Lemma typing_leq_term {cf:checker_flags} (Σ : global_env_ext) Γ t t' T T' : wf Σ.1 -> on_udecl Σ.1 Σ.2 -> Σ ;;; Γ |- t : T -> Σ ;;; Γ |- t' : T' -> - leq_term empty_global_env Σ t' t -> - (* No cumulativity of inductive types, as they can relate + leq_term empty_global_env Σ t' t -> + (* No cumulativity of inductive types, as they can relate inductives in different sorts. *) Σ ;;; Γ |- t' : T. Proof. intros wfΣ onu Ht. revert Σ wfΣ Γ t T Ht onu t' T'. - eapply (typing_ind_env + eapply (typing_ind_env (fun Σ Γ t T => forall (onu : on_udecl Σ.1 Σ.2), forall t' T' : term, Σ ;;; Γ |- t' : T' -> leq_term empty_global_env Σ t' t -> Σ;;; Γ |- t' : T) @@ -482,7 +482,7 @@ Proof. apply cumul_Sort. now apply leq_universe_super. - eapply inversion_Prod in X4 as [s1' [s2' [Ha [Hb Hs]]]]; auto. - specialize (X1 onu _ _ Ha). + specialize (X1 onu _ _ Ha). specialize (X1 (eq_term_empty_leq_term X5_1)). apply eq_term_empty_eq_term in X5_1. eapply context_conversion in Hb. 3:{ constructor. apply conv_ctx_refl. constructor. @@ -515,7 +515,7 @@ Proof. constructor; auto; fvs. eapply ws_cumul_pb_refl. now eapply typing_closed_ctx in codom. eapply type_closed, closedn_on_free_vars in X2. - now len in X2; len. + now len in X2; len. - eapply inversion_LetIn in X6 as (s1' & A & dom & bod & codom & cum); auto. specialize (X1 onu _ _ dom (eq_term_empty_leq_term X7_2)). @@ -524,7 +524,7 @@ Proof. apply eq_term_empty_eq_term in X7_2. assert(Σ ⊢ Γ ,, vdef na t ty = Γ ,, vdef n b b_ty). { constructor. eapply ws_cumul_ctx_pb_refl. fvs. constructor => //. - constructor; fvs. constructor; fvs. } + constructor; fvs. constructor; fvs. } specialize (X5 onu u A). forward X5 by eapply closed_context_conversion; eauto; pcuic. specialize (X5 X7_3). @@ -541,7 +541,7 @@ Proof. constructor; auto; fvs. constructor; fvs. apply ws_cumul_pb_refl; fvs. - + - eapply inversion_App in X6 as (na' & A' & B' & hf & ha & cum); auto. unfold leq_term in X1. eapply eq_term_upto_univ_empty_impl in X7_1. @@ -617,7 +617,7 @@ Proof. now rewrite on_free_vars_subst_instance. } eapply PCUICEquality.subst_eq_term. eapply PCUICUnivSubstitutionConv.eq_term_upto_univ_subst_instance; eauto; typeclasses eauto. - + - eassert (ctx_inst _ _ _ _ _) as Hctxi by now eapply ctx_inst_impl with (1 := X5). assert (isType Σ Γ (mkApps ptm (indices ++ [c]))). { eapply validity. econstructor; eauto. all:split; eauto. @@ -681,7 +681,7 @@ Proof. + split. eapply PCUICWeakeningTyp.weaken_wf_local; tea. eapply wf_projection_context; tea. - eapply validity in X3. + eapply validity in X3. now eapply (isType_mkApps_Ind_inv _ a) in X3 as [? [? []]]. eapply PCUICInductives.projection_subslet; eauto. eapply validity in X3; auto. @@ -706,7 +706,7 @@ Proof. destruct a as [[[eqty _] _] _]. constructor. eapply eq_term_empty_leq_term in eqty. now eapply leq_term_empty_leq_term. - + - eapply inversion_CoFix in X2 as (decl' & fixguard' & Hnth & types' & bodies & wfcofix & cum); auto. eapply type_Cumul_alt. econstructor; eauto. @@ -728,7 +728,7 @@ Proof. auto. Qed. -Lemma typing_eq_term {cf:checker_flags} (Σ : global_env_ext) Γ t t' T T' : +Lemma typing_eq_term {cf:checker_flags} (Σ : global_env_ext) Γ t t' T T' : wf_ext Σ -> Σ ;;; Γ |- t : T -> Σ ;;; Γ |- t' : T' -> diff --git a/pcuic/theories/PCUICProgram.v b/pcuic/theories/PCUICProgram.v index 5d7ff4dec..c78791603 100644 --- a/pcuic/theories/PCUICProgram.v +++ b/pcuic/theories/PCUICProgram.v @@ -5,19 +5,19 @@ From MetaCoq.PCUIC Require Import PCUICAstUtils PCUICAst PCUICGlobalEnv PCUICTyp (** Global environment with a map for efficient lookups *) -Record global_env_map := +Record global_env_map := { trans_env_env :> global_env; - trans_env_map : EnvMap.t global_decl; + trans_env_map : EnvMap.t global_decl; trans_env_repr : EnvMap.repr trans_env_env.(declarations) trans_env_map }. -Program Definition build_global_env_map (g : global_env) : global_env_map := - {| trans_env_env := g; +Program Definition build_global_env_map (g : global_env) : global_env_map := + {| trans_env_env := g; trans_env_map := EnvMap.EnvMap.of_global_env g.(declarations) |}. - + Definition global_env_ext_map := global_env_map * universes_decl. Definition pcuic_program : Type := global_env_ext_map * term. - + Definition global_env_ext_map_global_env_ext (g : global_env_ext_map) : global_env_ext := (trans_env_env (fst g), g.2). Coercion global_env_ext_map_global_env_ext : global_env_ext_map >-> global_env_ext. @@ -39,7 +39,7 @@ Module TransLookup. Definition lookup_inductive Σ ind := match lookup_minductive Σ (inductive_mind ind) with - | Some mdecl => + | Some mdecl => match nth_error mdecl.(ind_bodies) (inductive_ind ind) with | Some idecl => Some (mdecl, idecl) | None => None diff --git a/pcuic/theories/PCUICProgress.v b/pcuic/theories/PCUICProgress.v index e08411aac..5bad2e853 100644 --- a/pcuic/theories/PCUICProgress.v +++ b/pcuic/theories/PCUICProgress.v @@ -21,7 +21,7 @@ From Equations Require Import Equations. Lemma eval_tCase {cf : checker_flags} {Σ : global_env_ext} ci p discr brs res T : wf Σ -> Σ ;;; [] |- tCase ci p discr brs : T -> - eval Σ (tCase ci p discr brs) res -> + eval Σ (tCase ci p discr brs) res -> ∑ c u args, red Σ [] (tCase ci p discr brs) (tCase ci p ((mkApps (tConstruct ci.(ci_ind) c u) args)) brs). Proof. intros wf wt H. depind H; try now (cbn in *; congruence). @@ -29,7 +29,7 @@ Proof. eexists _, _, _. eapply red_case_c. eapply wcbeval_red. 2: eauto. eapply cinv. - eapply inversion_Case in wt as wt'; eauto. destruct wt' as (? & ? & ? & ? & cinv & ?). assert (Hred1 : Σ;;; [] |- tCase ip p discr brs ⇝* tCase ip p (mkApps fn args) brs). { - etransitivity. { eapply red_case_c. eapply wcbeval_red. 2: eauto. eapply cinv. } + etransitivity. { eapply red_case_c. eapply wcbeval_red. 2: eauto. eapply cinv. } econstructor. econstructor. rewrite closed_unfold_cofix_cunfold_eq. eauto. enough (closed (mkApps (tCoFix mfix idx) args)) as Hcl by (rewrite closedn_mkApps in Hcl; solve_all). @@ -39,7 +39,7 @@ Proof. edestruct IHeval2 as (c & u & args0 & IH); eauto using subject_reduction. exists c, u, args0. etransitivity; eauto. Qed. - + Local Existing Instance config.extraction_checker_flags. Inductive typing_spine_pred {cf : checker_flags} Σ (Γ : context) (P : forall t T (H : Σ ;;; Γ |- t : T), Type) : term -> list term -> term -> Type := @@ -61,15 +61,15 @@ Inductive typing_spine_pred {cf : checker_flags} Σ (Γ : context) (P : forall t forall H : Σ ;;; Γ |- hd : A, P hd A H -> typing_spine_pred Σ Γ P (subst10 hd B) tl B' -> - typing_spine_pred Σ Γ P ty (hd :: tl) B'. + typing_spine_pred Σ Γ P ty (hd :: tl) B'. Section WfEnv. Context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}. - Lemma typing_spine_pred_strengthen {Γ P T args U} : + Lemma typing_spine_pred_strengthen {Γ P T args U} : typing_spine_pred Σ Γ P T args U -> isType Σ Γ T -> - forall T', + forall T', isType Σ Γ T' -> Σ ;;; Γ ⊢ T' ≤ T -> typing_spine_pred Σ Γ P T' args U. @@ -81,7 +81,7 @@ Section WfEnv. clear p. eapply inversion_Prod in H' as (? & ? & ? & ? & ?); tea. eapply isType_subst. econstructor. econstructor. rewrite subst_empty; eauto. - econstructor; cbn; eauto. + econstructor; cbn; eauto. } do 3 forward IHX by pcuic. intros Hsub. @@ -104,14 +104,14 @@ Proof. econstructor. eexists; eauto. eexists; eauto. eapply isType_ws_cumul_pb_refl. eexists; eauto. } intros Hf Ht. simpl in Hf. specialize (IHu (tApp f a) T). - epose proof (IHu Hf) as (T' & H' & s' & H1 & H2 & H3 & H4); tea. + epose proof (IHu Hf) as (T' & H' & s' & H1 & H2 & H3 & H4); tea. edestruct @inversion_App_size with (H := H') as (na' & A' & B' & s_ & Hf' & Ha & HA & Hs1 & Hs2 & Hs3 & HA'''); tea. - exists (tProd na' A' B'). exists Hf'. exists s_. exists HA. + exists (tProd na' A' B'). exists Hf'. exists s_. exists HA. split. rewrite <- H2. lia. split. rewrite <- Nat.le_max_l, <- H2. lia. - + unshelve econstructor. - 5: eauto. 1: eauto. + 5: eauto. 1: eauto. 3:eapply isType_ws_cumul_pb_refl; eexists; eauto. 1: eexists; eauto. 1, 2: rewrite <- H2; lia. @@ -120,7 +120,7 @@ Proof. eapply inversion_Prod in HA as (? & ? & ? & ? & ?); tea. eapply isType_subst. econstructor. econstructor. rewrite subst_empty; eauto. econstructor; cbn; eauto. - Unshelve. eauto. + Unshelve. eauto. Qed. Lemma typing_ind_env_app_size `{cf : checker_flags} : @@ -128,7 +128,7 @@ forall (P : global_env_ext -> context -> term -> term -> Type) (Pdecl := fun Σ Γ wfΓ t T tyT => P Σ Γ t T) (PΓ : global_env_ext -> context -> Type), - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ), + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ), All_local_env_over typing Pdecl Σ Γ wfΓ -> PΓ Σ Γ) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : nat) decl, @@ -197,10 +197,10 @@ forall (P : global_env_ext -> context -> term -> term -> Type) consistent_instance_ext Σ mdecl.(ind_universes) u -> P Σ Γ (tConstruct ind i u) (type_of_constructor mdecl cdecl (ind, i) u)) -> - (forall (Σ : global_env_ext) (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ), + (forall (Σ : global_env_ext) (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ), forall (ci : case_info) p c brs indices ps mdecl idecl (isdecl : declared_inductive Σ.1 ci.(ci_ind) mdecl idecl), - Forall_decls_typing P Σ.1 -> + Forall_decls_typing P Σ.1 -> PΓ Σ Γ -> mdecl.(ind_npars) = ci.(ci_npar) -> eq_context_upto_names p.(pcontext) (ind_predicate_context ci.(ci_ind) mdecl idecl) -> @@ -212,7 +212,7 @@ forall (P : global_env_ext -> context -> term -> term -> Type) wf_local Σ (Γ ,,, predctx) -> PΓ Σ (Γ ,,, predctx) -> is_allowed_elimination Σ idecl.(ind_kelim) ps -> - PCUICTyping.ctx_inst (Prop_conj typing P) Σ Γ (p.(pparams) ++ indices) + PCUICTyping.ctx_inst (Prop_conj typing P) Σ Γ (p.(pparams) ++ indices) (List.rev (subst_instance p.(puinst) (mdecl.(ind_params) ,,, idecl.(ind_indices)))) -> Σ ;;; Γ |- c : mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices) -> P Σ Γ c (mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices)) -> @@ -249,7 +249,7 @@ forall (P : global_env_ext -> context -> term -> term -> Type) let types := fix_context mfix in cofix_guard Σ Γ mfix -> nth_error mfix n = Some decl -> - PΓ Σ (Γ ,,, types) -> + PΓ Σ (Γ ,,, types) -> All (on_def_type (lift_typing2 typing P Σ) Γ) mfix -> All (on_def_body (lift_typing2 typing P Σ) types Γ) mfix -> wf_cofixpoint Σ.1 mfix -> @@ -271,7 +271,7 @@ forall (P : global_env_ext -> context -> term -> term -> Type) Σ ;;; Γ |- A <=s B -> P Σ Γ t B) -> - env_prop P PΓ. + env_prop P PΓ. Proof. intros P Pdecl PΓ. intros XΓ X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 Σ wfΣ Γ t T H. @@ -281,15 +281,15 @@ Proof. destruct (decompose_app t) as [t1 L]. subst. rename t1 into t. cbn in *. replace (tApp (mkApps t L) u) with (mkApps t (L ++ [u])) by now rewrite mkApps_app. - + pose proof (@inversion_mkApps cf) as Happs. specialize Happs with (H := Ht). forward Happs; eauto. destruct (Happs _ Hprod) as (A' & Hf & s' & HA & sz_f & sz_A & HL). - destruct @inversion_Prod_size with (H := Hprod) as (s1 & s2 & H1 & H2 & Hs1 & Hs2 & Hsub); [ eauto | ]. + destruct @inversion_Prod_size with (H := Hprod) as (s1 & s2 & H1 & H2 & Hs1 & Hs2 & Hsub); [ eauto | ]. eapply X4. 6:eauto. 4: exact HA. all: eauto. - intros. eapply (IH _ _ Hf). lia. - Unshelve. 2:exact Hf. intros. eapply (IH _ _ Ht'). lia. - - clear sz_A. induction L in A', Hf, (* HA, sz_A, *) Ht, HL, t, Hf, IH (*, s' *) |- *. + - clear sz_A. induction L in A', Hf, (* HA, sz_A, *) Ht, HL, t, Hf, IH (*, s' *) |- *. + inversion HL; subst. inversion X13. econstructor. econstructor; eauto. eauto. eauto. eauto. eauto. eauto. econstructor. 1,2: eapply isType_apply; eauto. eapply ws_cumul_pb_refl. eapply typing_closed_context; eauto. eapply type_is_open_term. @@ -310,7 +310,7 @@ Lemma typing_ind_env `{cf : checker_flags} : (Pdecl := fun Σ Γ wfΓ t T tyT => P Σ Γ t T) (PΓ : global_env_ext -> context -> Type), - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ), + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ), All_local_env_over typing Pdecl Σ Γ wfΓ -> PΓ Σ Γ) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : nat) decl, @@ -350,11 +350,11 @@ Lemma typing_ind_env `{cf : checker_flags} : (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t : term) T B L s, PΓ Σ Γ -> Σ ;;; Γ |- T : tSort s -> P Σ Γ T (tSort s) -> - forall (Ht : Σ ;;; Γ |- t : T), P Σ Γ t T -> - + forall (Ht : Σ ;;; Γ |- t : T), P Σ Γ t T -> + (* Give a stronger induction hypothesis allowing to crawl under applications *) typing_spine_pred Σ Γ (fun u ty H => Σ ;;; Γ |- u : ty × P Σ Γ u ty) T L B -> - + P Σ Γ (mkApps t L) B) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) cst u (decl : constant_body), @@ -377,11 +377,11 @@ Lemma typing_ind_env `{cf : checker_flags} : PΓ Σ Γ -> consistent_instance_ext Σ mdecl.(ind_universes) u -> P Σ Γ (tConstruct ind i u) (type_of_constructor mdecl cdecl (ind, i) u)) -> - - (forall (Σ : global_env_ext) (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ), + + (forall (Σ : global_env_ext) (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ), forall (ci : case_info) p c brs indices ps mdecl idecl (isdecl : declared_inductive Σ.1 ci.(ci_ind) mdecl idecl), - Forall_decls_typing P Σ.1 -> + Forall_decls_typing P Σ.1 -> PΓ Σ Γ -> mdecl.(ind_npars) = ci.(ci_npar) -> eq_context_upto_names p.(pcontext) (ind_predicate_context ci.(ci_ind) mdecl idecl) -> @@ -393,7 +393,7 @@ Lemma typing_ind_env `{cf : checker_flags} : wf_local Σ (Γ ,,, predctx) -> PΓ Σ (Γ ,,, predctx) -> is_allowed_elimination Σ idecl.(ind_kelim) ps -> - PCUICTyping.ctx_inst (Prop_conj typing P) Σ Γ (p.(pparams) ++ indices) + PCUICTyping.ctx_inst (Prop_conj typing P) Σ Γ (p.(pparams) ++ indices) (List.rev (subst_instance p.(puinst) (mdecl.(ind_params) ,,, idecl.(ind_indices)))) -> Σ ;;; Γ |- c : mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices) -> P Σ Γ c (mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices)) -> @@ -407,7 +407,7 @@ Lemma typing_ind_env `{cf : checker_flags} : (Prop_conj typing P Σ (Γ ,,, brctxty.1) br.(bbody) brctxty.2) × (Prop_conj typing P) Σ (Γ ,,, brctxty.1) brctxty.2 (tSort ps))) 0 idecl.(ind_ctors) brs -> P Σ Γ (tCase ci p c brs) (mkApps ptm (indices ++ [c]))) -> - + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (p : projection) (c : term) u mdecl idecl cdecl pdecl (isdecl : declared_projection Σ.1 p mdecl idecl cdecl pdecl) args, Forall_decls_typing P Σ.1 -> PΓ Σ Γ -> @@ -493,7 +493,7 @@ Import PCUICGlobalEnv. Lemma typing_constructor_arity_exact {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind c u u' args} {mdecl idecl cdecl indices} : declared_constructor Σ (ind, c) mdecl idecl cdecl -> - Σ ;;; [] |- mkApps (tConstruct ind c u) args : mkApps (tInd ind u') indices -> + Σ ;;; [] |- mkApps (tConstruct ind c u) args : mkApps (tInd ind u') indices -> #|args| = cstr_arity mdecl cdecl. Proof. intros declc hc. @@ -503,7 +503,7 @@ Qed. Lemma typing_constructor_arity {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind c u args T} {mdecl idecl cdecl} : declared_constructor Σ (ind, c) mdecl idecl cdecl -> - Σ ;;; [] |- mkApps (tConstruct ind c u) args : T -> + Σ ;;; [] |- mkApps (tConstruct ind c u) args : T -> #|args| <= cstr_arity mdecl cdecl. Proof. intros declc hc. @@ -526,13 +526,13 @@ Proof. now rewrite (PCUICGlobalEnv.declared_minductive_ind_npars declc). Qed. -Lemma value_mkApps_inv' Σ f args : +Lemma value_mkApps_inv' Σ f args : negb (isApp f) -> - value Σ (mkApps f args) -> - atom f × All (value Σ) args. + value Σ (mkApps f args) -> + atom f × All (value Σ) args. Proof. intros napp. move/value_mkApps_inv => [] => //. - - intros [-> hf]. split => //. + - intros [-> hf]. split => //. - intros []. split; auto. destruct v; now constructor. Qed. @@ -555,7 +555,7 @@ Proof. Qed. Lemma typing_spine_axiom {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} Γ cst u cdecl args T : - declared_constant Σ cst cdecl -> + declared_constant Σ cst cdecl -> cdecl.(cst_body) = None -> typing_spine Σ Γ (tConst cst u) args T -> args = []. Proof. @@ -565,11 +565,11 @@ Proof. now eapply invert_cumul_axiom_prod in w. Qed. -Lemma typing_value_head_napp {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} fn args hd T : +Lemma typing_value_head_napp {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} fn args hd T : negb (isApp fn) -> - Σ ;;; [] |- mkApps fn (args ++ [hd]) : T -> + Σ ;;; [] |- mkApps fn (args ++ [hd]) : T -> value Σ hd -> closed hd -> - value Σ (mkApps fn args) -> + value Σ (mkApps fn args) -> (∑ t' : term, red1 Σ (mkApps fn (args ++ [hd])) t') + value Σ (mkApps fn (args ++ [hd])). Proof. @@ -593,13 +593,13 @@ Proof. eapply inversion_Ind in hfn as [? [? [? [? [? cu]]]]]; tea. eapply typing_spine_strengthen in hcum. 3:tea. 2:{ eapply validity. econstructor; eauto. } right. eapply value_app. constructor. eauto with pcuic. - * (* constructor *) + * (* constructor *) right. eapply value_app; auto. 2:{ eapply All_app_inv; eauto. } pose proof hfn as hfn'. eapply inversion_Construct in hfn' as [mdecl [idecl [cdecl [wf [declc _]]]]]; tea. eapply (typing_constructor_arity declc) in ht. econstructor; tea. - * (* fix *) + * (* fix *) destruct (isStuckFix (tFix mfix idx) (args ++ [hd])) eqn:E. + right. eapply value_stuck_fix; eauto with pcuic. + cbn in E. @@ -626,10 +626,10 @@ Proof. now eapply typing_spine_axiom, app_tip_nil in hcum. Qed. -Lemma typing_value_head {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} fn args hd T : - Σ ;;; [] |- mkApps fn (args ++ [hd]) : T -> +Lemma typing_value_head {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} fn args hd T : + Σ ;;; [] |- mkApps fn (args ++ [hd]) : T -> value Σ hd -> closed hd -> - value Σ (mkApps fn args) -> + value Σ (mkApps fn args) -> (∑ t' : term, red1 Σ (mkApps fn (args ++ [hd])) t') + value Σ (mkApps fn (args ++ [hd])). Proof. @@ -641,7 +641,7 @@ Proof. rewrite mkApps_app //. Qed. -Lemma cstr_branch_context_assumptions ci mdecl cdecl : +Lemma cstr_branch_context_assumptions ci mdecl cdecl : context_assumptions (cstr_branch_context ci mdecl cdecl) = context_assumptions (cstr_args cdecl). Proof. @@ -650,7 +650,7 @@ Proof. now do 2 rewrite !context_assumptions_subst_context ?context_assumptions_lift_context. Qed. -Lemma progress `{cf : checker_flags}: +Lemma progress `{cf : checker_flags}: env_prop (fun Σ Γ t T => axiom_free Σ -> Γ = [] -> Σ ;;; Γ |- t : T -> {t' & red1 Σ t t'} + (value Σ t)) (fun _ _ => True). Proof with eauto with wcbv; try congruence. @@ -716,7 +716,7 @@ Proof with eauto with wcbv; try congruence. eapply PCUICCanonicity.value_canonical in IH; eauto. unfold head in IH. rewrite (PCUICInduction.mkApps_decompose_app c) in H, Hc, Hval |- *. - destruct (decompose_app c) as [h l]. + destruct (decompose_app c) as [h l]. cbn - [decompose_app] in *. destruct h; inv IH. + eapply invert_Proj_Construct in H as H_; sq; eauto. destruct H_ as (<- & -> & Hl). @@ -756,7 +756,7 @@ Proof. Qed. Lemma red1_incl {cf : checker_flags} {Σ t t' } : - closed t -> + closed t -> red1 Σ t t' -> PCUICReduction.red1 Σ [] t t'. Proof. intros Hcl Hred. @@ -765,7 +765,7 @@ Proof. 1,2: now rewrite closed_subst; eauto; econstructor; eauto. - now rewrite e0 /cstr_arity -e1 -e2. - rewrite !tApp_mkApps -!mkApps_app. econstructor. eauto. - unfold is_constructor. now rewrite nth_error_app2 // Nat.sub_diag. + unfold is_constructor. now rewrite nth_error_app2 // Nat.sub_diag. - unfold cunfold_cofix in e. destruct nth_error as [d | ] eqn:E; try congruence. inversion e; subst. econstructor. unfold unfold_cofix. rewrite E. repeat f_equal. @@ -780,7 +780,7 @@ Global Hint Constructors value eval : wcbv. Global Hint Resolve value_final : wcbv. (* Lemma eval_tApp_Construct {Σ a b ind c u args a'} - eval Σ a + eval Σ a eval Σ (tApp a b) (mkApps (tConstruct ind c u) (args ++ [a'])) *) @@ -834,7 +834,7 @@ Proof. exists v. sq. eapply red1_eval; eauto. now eapply subject_closed in HA. - exists t. sq. eapply value_final; eauto. -Qed. +Qed. From MetaCoq Require Import PCUICFirstorder. @@ -873,8 +873,8 @@ Proof. - assert (x = y) as <- by eauto. eauto. Qed. -Lemma ws_wcbv_standardization {Σ i u args mind} {t v : ws_term (fun _ => false)} : wf_ext Σ -> axiom_free Σ -> - Σ ;;; [] |- t : mkApps (tInd i u) args -> +Lemma ws_wcbv_standardization {Σ i u args mind} {t v : ws_term (fun _ => false)} : wf_ext Σ -> axiom_free Σ -> + Σ ;;; [] |- t : mkApps (tInd i u) args -> lookup_env Σ (i.(inductive_mind)) = Some (InductiveDecl mind) -> @firstorder_ind Σ (firstorder_env Σ) i -> closed_red Σ [] t v -> @@ -890,7 +890,7 @@ Proof. 2:{ econstructor; eauto. eapply subject_is_open_term. eauto. } destruct v as [v Hv]. assert (v = v'') as <- by (eapply irred_equal; eauto). - assert (firstorder_value Σ [] v'). { + assert (firstorder_value Σ [] v'). { eapply firstorder_value_spec; eauto. eapply subject_reduction_eval; eauto. eapply eval_to_value. eauto. @@ -900,8 +900,8 @@ Proof. intros. eapply firstorder_value_irred; eauto. Qed. -Lemma wcbv_standardization {Σ i u args mind} {t v : term} : wf_ext Σ -> axiom_free Σ -> - Σ ;;; [] |- t : mkApps (tInd i u) args -> +Lemma wcbv_standardization {Σ i u args mind} {t v : term} : wf_ext Σ -> axiom_free Σ -> + Σ ;;; [] |- t : mkApps (tInd i u) args -> lookup_env Σ (i.(inductive_mind)) = Some (InductiveDecl mind) -> @firstorder_ind Σ (firstorder_env Σ) i -> red Σ [] t v -> @@ -922,4 +922,4 @@ Proof. - now eapply subject_closed in Hty. - eapply @subject_closed with (Γ := []); eauto. eapply subject_reduction; eauto. -Qed. +Qed. diff --git a/pcuic/theories/PCUICRedTypeIrrelevance.v b/pcuic/theories/PCUICRedTypeIrrelevance.v index d26a299ef..762393a0b 100644 --- a/pcuic/theories/PCUICRedTypeIrrelevance.v +++ b/pcuic/theories/PCUICRedTypeIrrelevance.v @@ -1,12 +1,12 @@ -From Coq Require Import ssreflect. +From Coq Require Import ssreflect. From Equations Require Import Equations. From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping PCUICLiftSubst +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping PCUICLiftSubst PCUICReduction PCUICContextReduction. From Coq Require Import CRelationClasses. -(** Types and names of variables are irrelevant during reduction. +(** Types and names of variables are irrelevant during reduction. More precisely, we only need to preserve bodies of let declarations in contexts for reductions to be preserved. *) @@ -26,7 +26,7 @@ Lemma All2_fold_nth_ass {P n Γ Γ' d} : P Γs Γs' d d')%type }. Proof. induction n in Γ, Γ', d |- *; destruct Γ; intros Hrel H; noconf H. - - depelim Hrel. intro ass. + - depelim Hrel. intro ass. simpl. eexists; intuition eauto. now depelim ass. - intros ass. depelim Hrel. @@ -46,7 +46,7 @@ Section ContextChangeTypesReduction. Context (Σ : global_env). Definition pres_let_bodies (c : context_decl) (c' : context_decl) : Type := - match c.(decl_body) with + match c.(decl_body) with | None => unit | Some b => decl_body c' = Some b end. @@ -83,7 +83,7 @@ Local Hint Extern 4 (pres_let_bodies _ _) => exact tt || exact eq_refl : core. Local Hint Extern 4 (All2_fold (fun _ _ => _) (_ ,, _) (_ ,, _)) => constructor : core. Hint Constructors unit : core. -Lemma pres_let_bodies_ctx_refl : +Lemma pres_let_bodies_ctx_refl : Reflexive (All2_fold (fun _ _ : context => pres_let_bodies)). Proof using Type. intros x. @@ -91,7 +91,7 @@ Proof using Type. Qed. Lemma context_pres_let_bodies_red1 Γ Γ' s t : - All2_fold (fun _ _ => pres_let_bodies) Γ Γ' -> + All2_fold (fun _ _ => pres_let_bodies) Γ Γ' -> red1 Σ Γ s t -> red1 Σ Γ' s t. Proof using Type. intros HT X0. induction X0 using red1_ind_all in Γ', HT |- *; eauto. @@ -120,9 +120,9 @@ Proof using Type. eapply All2_fold_app; eauto. eapply pres_let_bodies_ctx_refl. Qed. - + Lemma context_pres_let_bodies_red Γ Γ' s t : - All2_fold (fun _ _ => pres_let_bodies) Γ Γ' -> + All2_fold (fun _ _ => pres_let_bodies) Γ Γ' -> red Σ Γ s t -> red Σ Γ' s t. Proof using Type. intros pres. diff --git a/pcuic/theories/PCUICReduction.v b/pcuic/theories/PCUICReduction.v index 443407f3f..a06228df0 100644 --- a/pcuic/theories/PCUICReduction.v +++ b/pcuic/theories/PCUICReduction.v @@ -18,7 +18,7 @@ Local Open Scope type_scope. Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := (** Reductions *) (** Beta *) -| red_beta na t b a : +| red_beta na t b a : Σ ;;; Γ |- tApp (tLambda na t b) a ⇝ b {0 := a} (** Let *) @@ -33,7 +33,7 @@ Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := | red_iota ci c u args p brs br : nth_error brs c = Some br -> #|args| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat -> - Σ ;;; Γ |- tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs + Σ ;;; Γ |- tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs ⇝ iota_red ci.(ci_npar) p args br (** Fix unfolding, with guard *) @@ -74,15 +74,15 @@ Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := | case_red_param ci p params' c brs : OnOne2 (fun t u => Σ ;;; Γ |- t ⇝ u) p.(pparams) params' -> Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci (set_pparams p params') c brs - + | case_red_return ci p preturn' c brs : Σ ;;; Γ ,,, inst_case_predicate_context p |- p.(preturn) ⇝ preturn' -> Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci (set_preturn p preturn') c brs - + | case_red_discr ci p c c' brs : Σ ;;; Γ |- c ⇝ c' -> Σ ;;; Γ |- tCase ci p c brs ⇝ tCase ci p c' brs -| case_red_brs ci p c brs brs' : +| case_red_brs ci p c brs brs' : OnOne2 (fun br br' => on_Trel_eq (fun t u => Σ ;;; Γ ,,, inst_case_branch_context p br |- t ⇝ u) bbody bcontext br br') brs brs' -> @@ -190,13 +190,13 @@ Lemma red1_ind_all : P (Γ ,,, inst_case_predicate_context p) p.(preturn) preturn' -> P Γ (tCase ci p c brs) (tCase ci (set_preturn p preturn') c brs)) -> - + (forall (Γ : context) (ind : case_info) (p : predicate term) (c c' : term) (brs : list (branch term)), red1 Σ Γ c c' -> P Γ c c' -> P Γ (tCase ind p c brs) (tCase ind p c' brs)) -> (forall (Γ : context) ci p c brs brs', OnOne2 (fun br br' => - (on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, inst_case_branch_context p br)) + (on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, inst_case_branch_context p br)) (P (Γ ,,, inst_case_branch_context p br))) bbody bcontext br br')) brs brs' -> P Γ (tCase ci p c brs) (tCase ci p c brs')) -> @@ -262,7 +262,7 @@ Proof. intros params params' []. + constructor. split; auto. + constructor. auto. - + - revert brs' o. revert brs. fix auxl 3. @@ -419,7 +419,7 @@ Section ReductionCongruence. | tCtxCase_pars : case_info -> list_context (* params *) -> Instance.t -> context -> term -> (* predicate *) term (* discriminee *) -> list (branch term) (* branches *) -> term_context - | tCtxCase_pred : case_info -> list term (* params *) -> Instance.t -> + | tCtxCase_pred : case_info -> list term (* params *) -> Instance.t -> context -> (* context of predicate *) term_context (* type info *) -> term (* discriminee *) -> list (branch term) (* branches *) -> term_context @@ -469,11 +469,11 @@ Section ReductionCongruence. | tCtxApp_l f a => tApp (fill_context f) a; | tCtxApp_r f a => tApp f (fill_context a); | tCtxCase_pars ci pars puinst pctx pret c brs => - tCase ci {| pparams := fill_list_context pars; + tCase ci {| pparams := fill_list_context pars; puinst := puinst; pcontext := pctx; preturn := pret |} c brs ; - | tCtxCase_pred ci pars puinst pctx p c brs => + | tCtxCase_pred ci pars puinst pctx p c brs => tCase ci {| pparams := pars; puinst := puinst; pcontext := pctx; @@ -489,7 +489,7 @@ Section ReductionCongruence. fill_list_context (tCtxTail hd ctx) => hd :: fill_list_context ctx } with fill_branch_context (l : branch_context) : list (branch term) by struct l := - { fill_branch_context (tCtxHead_nat (bctx, ctx) l) => + { fill_branch_context (tCtxHead_nat (bctx, ctx) l) => {| bcontext := bctx; bbody := fill_context ctx |} :: l; fill_branch_context (tCtxTail_nat hd ctx) => hd :: fill_branch_context ctx }. @@ -515,7 +515,7 @@ Section ReductionCongruence. | tCtxApp_l f a | Γ => hole_context f Γ; | tCtxApp_r f a | Γ => hole_context a Γ; | tCtxCase_pars ci params puinst pctx pret c brs | Γ => hole_list_context params Γ; - | tCtxCase_pred ci params puinst pctx pret c brs | Γ => + | tCtxCase_pred ci params puinst pctx pret c brs | Γ => hole_context pret (Γ ,,, inst_case_context params puinst pctx); | tCtxCase_discr ci p c brs | Γ => hole_context c Γ; | tCtxCase_branch ci p c brs | Γ => hole_branch_context p brs Γ; @@ -555,15 +555,15 @@ Section ReductionCongruence. | tCtxApp_r f a => (wf_context a); | tCtxCase_pars ci pars puinst pctx pret c brs => wf_list_context pars; - | tCtxCase_pred ci pars puinst names pctx p c brs => - (∑ mdecl idecl, + | tCtxCase_pred ci pars puinst names pctx p c brs => + (∑ mdecl idecl, declared_inductive Σ ci.(ci_ind) mdecl idecl * - (pctx = case_predicate_context_gen ci.(ci_ind) mdecl idecl pars puinst names) * + (pctx = case_predicate_context_gen ci.(ci_ind) mdecl idecl pars puinst names) * wf_predicate_gen mdecl idecl pars names) * wf_context p; | tCtxCase_discr ci p c brs => wf_context c; - | tCtxCase_branch ci p c brs => + | tCtxCase_branch ci p c brs => (∑ mdecl idecl, declared_inductive Σ ci.(ci_ind) mdecl idecl * wf_predicate mdecl idecl p * @@ -579,7 +579,7 @@ Section ReductionCongruence. with wf_branch_context (info : inductive * mutual_inductive_body * one_inductive_body * predicate term) (brsctx : list constructor_body) (l : branch_context) : Type@{wf_context_i} by struct l := { | p | [] | tCtxHead_nat _ _ => False ; | p | [] | tCtxTail_nat _ _ => False ; - | (ind, mdecl, idecl, p) | cdecl :: cdecls | (tCtxHead_nat (bctx, bfullctx, ctx) l) => + | (ind, mdecl, idecl, p) | cdecl :: cdecls | (tCtxHead_nat (bctx, bfullctx, ctx) l) => Forall2 wf_branch cdecls l * wf_predicate mdecl idecl p * (case_branch_context ind mdecl p bctx cdecl = bfullctx) * @@ -601,7 +601,7 @@ Section ReductionCongruence. Arguments fill_list_context : simpl never. - (* Lemma wf_branch_context_branches p ctors x b : + (* Lemma wf_branch_context_branches p ctors x b : wf_branch_context p ctors b -> Forall2 wf_branch ctors (fill_branch_context x b). Proof. @@ -613,7 +613,7 @@ Section ReductionCongruence. - intros []. constructor; auto. Qed. *) - Lemma contextual_closure_red Γ t u : + Lemma contextual_closure_red Γ t u : contextual_closure (red Σ) Γ t u -> red Σ Γ t u. Proof using Type. induction 1; trea. @@ -621,7 +621,7 @@ Section ReductionCongruence. apply clos_rt_rt1n_iff in r0. etransitivity; tea. constructor. clear -r. - set (P := fun ctx t => + set (P := fun ctx t => forall Γ y, Σ ;;; (hole_context ctx Γ) |- x ⇝ y -> Σ ;;; Γ |- t ⇝ fill_context y ctx). set (P' := fun l fill_l => @@ -631,7 +631,7 @@ Section ReductionCongruence. set (P'' := fun l fill_l => forall p Γ y, red1 Σ (hole_branch_context p l Γ) x y -> - OnOne2 (fun br br' => + OnOne2 (fun br br' => let brctx := inst_case_branch_context p br in on_Trel_eq (red1 Σ (Γ ,,, brctx)) bbody bcontext br br') fill_l (fill_branch_context y l)). @@ -660,25 +660,25 @@ Section ReductionCongruence. Notation red1_one_term Γ := (@OnOne2 (term × _) (Trel_conj (on_Trel (red1 Σ Γ) fst) (on_Trel eq snd))). - Notation red_one_term Γ := + Notation red_one_term Γ := (@OnOne2 (term × _) (Trel_conj (on_Trel (red Σ Γ) fst) (on_Trel eq snd))). - + Notation red1_one_context_decl Γ := (@OnOne2 (context × _) (Trel_conj (on_Trel (red1_ctx_rel Σ Γ) fst) (on_Trel eq snd))). - Definition red_one_context_decl_rel Σ Γ := + Definition red_one_context_decl_rel Σ Γ := (OnOne2_local_env (on_one_decl (fun Δ t t' => red Σ (Γ ,,, Δ) t t'))). - + Notation red_one_context_decl Γ := - (@OnOne2 (context × _) + (@OnOne2 (context × _) (Trel_conj (on_Trel (red_ctx_rel Σ Γ) fst) (on_Trel eq snd))). - - Notation red1_one_branch p Γ := + + Notation red1_one_branch p Γ := (@OnOne2 _ (fun br br' => let ctx := inst_case_context p.(pparams) p.(puinst) (snd br) in Trel_conj (on_Trel (red1 Σ (Γ ,,, ctx)) fst) (on_Trel eq snd) br br')). - Notation red_one_branch p Γ := - (@OnOne2 _ (fun br br' => + Notation red_one_branch p Γ := + (@OnOne2 _ (fun br br' => let ctx := inst_case_context p.(pparams) p.(puinst) (snd br) in Trel_conj (on_Trel (red Σ (Γ ,,, ctx)) fst) (on_Trel eq snd) br br')). @@ -691,7 +691,7 @@ Section ReductionCongruence. redl l l2. Derive Signature for redl. - Lemma redl_preserve {T A P} (l l' : list (T × A)) : + Lemma redl_preserve {T A P} (l l' : list (T × A)) : (forall (x y : list (T × A)), P x y -> map snd x = map snd y) -> @redl _ _ P l l' -> map snd l = map snd l'. Proof using Type. @@ -702,7 +702,7 @@ Section ReductionCongruence. Definition redl_term {A} Γ := @redl term A (red1_one_term Γ). Definition redl_context {A} Γ := @redl context A (red1_one_context_decl Γ). Definition redl_branch p Γ := @redl term _ (red1_one_branch p Γ). - + Lemma OnOne2_red_redl : forall Γ A (l l' : list (term × A)), red_one_term Γ l l' -> @@ -726,7 +726,7 @@ Section ReductionCongruence. Qed. Definition cons_decl {A} (d : context_decl) (l : list (context × A)) := - match l with + match l with | [] => [] | (Γ , a) :: tl => (Γ ,, d, a) :: tl end. @@ -737,7 +737,7 @@ Section ReductionCongruence. Proof using Type. induction 1; intros. - constructor. - - econstructor. + - econstructor. * eapply IHX. * depelim p; simpl. + destruct hd, hd'. destruct p. @@ -768,7 +768,7 @@ Section ReductionCongruence. destruct hd as [t a], hd' as [t' a']. simpl in *. subst. red in p1. induction p1; unfold on_one_decl in *. - + red in r. induction r. + + red in r. induction r. * red in p. unfold redl_context. econstructor. 2:{ constructor. unfold on_Trel. simpl. @@ -788,7 +788,7 @@ Section ReductionCongruence. 2:{ constructor. unfold on_Trel. simpl. instantiate (1 := (Γ0 ,, vdef na b t', a')). simpl. intuition auto. constructor. simpl. - intuition auto. } + intuition auto. } constructor. } * clear -IHr. eapply (redl_context_impl _ _ _ IHr). @@ -886,7 +886,7 @@ Section ReductionCongruence. OnOne2 (fun br br' => let ctx := inst_case_branch_context p br in on_Trel_eq (red Σ (Γ ,,, ctx)) bbody bcontext br br') l l' -> - redl_branch p Γ (map (fun x => (bbody x, bcontext x)) l) + redl_branch p Γ (map (fun x => (bbody x, bcontext x)) l) (map (fun x => (bbody x, bcontext x)) l'). Proof using Type. intros p Γ l l' h. @@ -956,7 +956,7 @@ Section ReductionCongruence. Notation recomp_branch := (fun x : term * context => {| bbody := x.1; bcontext := x.2 |}). Notation decomp_branch' := (fun x : branch term => (bcontext x, bbody x)). Notation recomp_branch' := (fun x : context * term => {| bbody := x.2; bcontext := x.1 |}). - + Lemma list_map_swap_eq : forall l l', map decomp_branch l = map decomp_branch l' -> @@ -992,7 +992,7 @@ Section ReductionCongruence. - reflexivity. - cbn. destruct a. rewrite <- IHl. reflexivity. Qed. - + Lemma map_recomp_decomp' : forall l, l = map decomp_branch' (map recomp_branch' l). Proof using Type. @@ -1008,7 +1008,7 @@ Section ReductionCongruence. - reflexivity. - cbn. destruct a. rewrite <- IHl. reflexivity. Qed. - + Lemma map_decomp_recomp' : forall l, l = map recomp_branch' (map decomp_branch' l). Proof using Type. @@ -1073,7 +1073,7 @@ Section ReductionCongruence. generalize (List.rev l) as l'; induction l'; simpl; auto. rewrite mkApps_app. now rewrite <- IHl'. Qed. - + Lemma red1_mkApps_f : forall t u l, red1 Σ Γ t u -> @@ -1123,7 +1123,7 @@ Section ReductionCongruence. + now eapply (red_ctx_congr (tCtxLetIn_b _ _ tCtxHole _)). + now eapply (red_ctx_congr (tCtxLetIn_r _ _ _ tCtxHole)). Qed. - + Lemma red_one_param : forall ci p c brs pars', OnOne2 (red Σ Γ) p.(pparams) pars' -> @@ -1176,7 +1176,7 @@ Section ReductionCongruence. { now destruct p. } eapply red_one_param; eassumption. Qed. - + (* Lemma red_one_pcontext : forall ci p c brs pcontext', red1_ctx_rel Σ Γ p.(pcontext) pcontext' -> @@ -1187,7 +1187,7 @@ Section ReductionCongruence. constructor. now constructor. Qed. *) -(* +(* Lemma red_case_pcontext_red_ctx_rel : forall ci p c brs pcontext', red_ctx_rel Σ Γ p.(pcontext) pcontext' -> @@ -1203,11 +1203,11 @@ Section ReductionCongruence. { now destruct p. } eapply red_one_pcontext. eassumption. Qed. - + Lemma red_case_pcontext : forall ci p c brs pcontext', OnOne2_local_env - (on_one_decl (fun (Δ : context) (t t' : term) => red Σ (Γ,,, Δ) t t')) + (on_one_decl (fun (Δ : context) (t t' : term) => red Σ (Γ,,, Δ) t t')) p.(pcontext) pcontext' -> red Σ Γ (tCase ci p c brs) (tCase ci (set_pcontext p pcontext') c brs). Proof. @@ -1219,11 +1219,11 @@ Section ReductionCongruence. Lemma red_case_p : forall ci p c brs pret', red Σ (Γ ,,, inst_case_predicate_context p) p.(preturn) pret' -> - red Σ Γ (tCase ci p c brs) + red Σ Γ (tCase ci p c brs) (tCase ci (set_preturn p pret') c brs). Proof using Type. intros ci p c brs p' h. - unshelve epose proof + unshelve epose proof (red_ctx_congr (tCtxCase_pred ci p.(pparams) p.(puinst) p.(pcontext) tCtxHole c brs) h). simp fill_context in X. destruct p; auto. @@ -1237,13 +1237,13 @@ Section ReductionCongruence. intros ci p c brs c' h. rst_induction h; eauto with pcuic. Qed. - - Lemma map_bcontext_redl {pred} {l l' : list (term * context)} : + + Lemma map_bcontext_redl {pred} {l l' : list (term * context)} : @redl _ _ (red1_one_branch pred Γ) l l' -> map snd l = map snd l'. Proof using Type. induction 1; auto. rewrite IHX. clear -p . - induction p; simpl. + induction p; simpl. - destruct p as [? ?]. congruence. - now f_equal. Qed. @@ -1264,7 +1264,7 @@ Section ReductionCongruence. forall l l', OnOne2 (fun br br' => let ctx := br.(bcontext) in - on_Trel_eq (red Σ (Γ ,,, ctx)) bbody bcontext br br') l l' -> + on_Trel_eq (red Σ (Γ ,,, ctx)) bbody bcontext br br') l l' -> OnOne2 (fun br br' => let ctx := br.(bcontext) in on_Trel_eq (red Σ (Γ ,,, ctx)) bbody bcontext br br') l l' + @@ -1277,7 +1277,7 @@ Section ReductionCongruence. Lemma red_case_one_brs : forall (ci : case_info) p c brs brs', - OnOne2 (fun br br' => + OnOne2 (fun br br' => let brctx := inst_case_branch_context p br in on_Trel_eq (red Σ (Γ ,,, brctx)) bbody bcontext br br') brs brs' -> @@ -1299,7 +1299,7 @@ Section ReductionCongruence. All3 R l l' l'' -> #|l| = #|l'| /\ #|l'| = #|l''|. Proof using Type. induction 1; simpl; intuition auto. - f_equal. assumption. - - f_equal. assumption. + - f_equal. assumption. Qed. Lemma All3_many_OnOne2All : @@ -1339,18 +1339,18 @@ Section ReductionCongruence. Qed. *) Definition red_one_brs p Γ brs brs' := - OnOne2 (fun br br' => + OnOne2 (fun br br' => let ctx := inst_case_branch_context p br in on_Trel_eq (red Σ (Γ ,,, ctx)) bbody bcontext br br') brs brs'. Definition red_brs p Γ brs brs' := - All2 (fun br br' => + All2 (fun br br' => let ctx := inst_case_branch_context p br in on_Trel_eq (red Σ (Γ ,,, ctx)) bbody bcontext br br') brs brs'. - Lemma rtrans_clos_incl {A} (R S : A -> A -> Type) : + Lemma rtrans_clos_incl {A} (R S : A -> A -> Type) : (forall x y, R x y -> rtrans_clos S x y) -> forall x y, rtrans_clos R x y -> rtrans_clos S x y. @@ -1380,7 +1380,7 @@ Section ReductionCongruence. etransitivity. - constructor. constructor. intros ctx. rewrite -/ctx in p0. tea. - constructor. - constructor. simpl. destruct p0. + constructor. simpl. destruct p0. rewrite /inst_case_branch_context /= in r *. rewrite -e. split; auto. * clear -IHh. rename IHh into h. @@ -1425,7 +1425,7 @@ Section ReductionCongruence. red Σ (Γ ,,, inst_case_predicate_context p) p.(preturn) pret' -> red Σ Γ c c' -> red_brs p Γ brs brs' -> - red Σ Γ (tCase ci p c brs) + red Σ Γ (tCase ci p c brs) (tCase ci {| pparams := pars'; puinst := p.(puinst); pcontext := p.(pcontext); preturn := pret' |} c' brs'). Proof using Type. @@ -1977,8 +1977,8 @@ Ltac OnOne2_All2 := #[global] Hint Extern 0 (All2 _ _ _) => OnOne2_All2; intuition auto with pred : pred. -Lemma nth_error_firstn_skipn {A} {l : list A} {n t} : - nth_error l n = Some t -> +Lemma nth_error_firstn_skipn {A} {l : list A} {n t} : + nth_error l n = Some t -> l = firstn n l ++ [t] ++ skipn (S n) l. Proof. induction l in n |- *; destruct n; simpl; try congruence. intros. specialize (IHl _ H). @@ -1999,10 +1999,10 @@ Proof. exists x; now f_equal. Qed. -Lemma nth_error_map2 {A B C} (f : A -> B -> C) (l : list A) (l' : list B) n x : +Lemma nth_error_map2 {A B C} (f : A -> B -> C) (l : list A) (l' : list B) n x : nth_error (map2 f l l') n = Some x -> ∑ lx l'x, (nth_error l n = Some lx) * - (nth_error l' n = Some l'x) * + (nth_error l' n = Some l'x) * (f lx l'x = x). Proof. induction l in l', n, x |- *; destruct l', n; simpl; auto => //. diff --git a/pcuic/theories/PCUICSR.v b/pcuic/theories/PCUICSR.v index a94045c04..ab4a8e132 100644 --- a/pcuic/theories/PCUICSR.v +++ b/pcuic/theories/PCUICSR.v @@ -1,7 +1,7 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICUtils PCUICOnOne - PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICGlobalEnv PCUICWeakeningEnvConv + PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICGlobalEnv PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICWeakeningConv PCUICWeakeningTyp PCUICSubstitution PCUICCasesContexts PCUICClosed PCUICClosedTyp PCUICClosedConv PCUICCumulativity PCUICGeneration PCUICReduction @@ -27,9 +27,9 @@ Ltac rename_hyp h ht ::= my_rename_hyp h ht. Arguments Nat.sub : simpl nomatch. Arguments Universe.sort_of_product : simpl nomatch. -(* Preservation of wf_*fixpoint *) +(* Preservation of wf_*fixpoint *) -Lemma wf_fixpoint_red1_type {cf Σ} {wfΣ : wf Σ} Γ mfix mfix1 : +Lemma wf_fixpoint_red1_type {cf Σ} {wfΣ : wf Σ} Γ mfix mfix1 : wf_fixpoint Σ mfix -> OnOne2 (fun x y : def term => @@ -41,7 +41,7 @@ Proof. move: wffix; unfold wf_fixpoint, wf_fixpoint_gen. move/andb_and => [] isl wf. apply/andP; split. { clear wf. solve_all. - revert isl. + revert isl. induction o; depelim isl; constructor; auto. destruct p. destruct c. noconf e. congruence. } clear isl. move: wf. @@ -60,7 +60,7 @@ Proof. apply decompose_prod_assum_it_mkProd_or_LetIn in decomp. simpl in decomp. subst dtype. - destruct (red1_it_mkProd_or_LetIn_smash redty Hnth) as + destruct (red1_it_mkProd_or_LetIn_smash redty Hnth) as (ctx & t' & decomp & d & [hnth di]). rewrite decomp hnth. unfold head in di. destruct decompose_app; simpl in *. @@ -75,7 +75,7 @@ Proof. discriminate. Qed. -Lemma wf_fixpoint_red1_body {cf Σ} {wfΣ : wf Σ} Γ mfix mfix1 : +Lemma wf_fixpoint_red1_body {cf Σ} {wfΣ : wf Σ} Γ mfix mfix1 : wf_fixpoint Σ mfix -> OnOne2 (fun x y : def term => @@ -87,7 +87,7 @@ Proof. move: wffix; unfold wf_fixpoint, wf_fixpoint_gen. move/andb_and => [] isl wf. apply/andP; split. { clear wf. solve_all. - revert isl. + revert isl. induction o; depelim isl; constructor; auto. destruct p. destruct c. noconf e. destruct (dbody hd) => //. depelim clrel_rel; solve_discr. @@ -103,7 +103,7 @@ Proof. - simpl. now rewrite IHo. Qed. -Lemma wf_cofixpoint_red1_type {cf:checker_flags} (Σ : global_env_ext) Γ mfix mfix1 : +Lemma wf_cofixpoint_red1_type {cf:checker_flags} (Σ : global_env_ext) Γ mfix mfix1 : wf Σ.1 -> wf_cofixpoint Σ.1 mfix -> OnOne2 @@ -143,7 +143,7 @@ Proof. discriminate. Qed. -Lemma wf_cofixpoint_red1_body {cf:checker_flags} (Σ : global_env_ext) Γ mfix mfix1 : +Lemma wf_cofixpoint_red1_body {cf:checker_flags} (Σ : global_env_ext) Γ mfix mfix1 : wf Σ.1 -> wf_cofixpoint Σ.1 mfix -> OnOne2 @@ -169,12 +169,12 @@ Qed. #[global] Hint Extern 0 (conv_context _ _ _) => constructor : pcuic. #[global] Hint Extern 0 (cumul_context _ _ _) => constructor : pcuic. -#[global] Hint Extern 4 (∑ s : Universe.t, typing _ _ ?T (tSort s)) => - match goal with +#[global] Hint Extern 4 (∑ s : Universe.t, typing _ _ ?T (tSort s)) => + match goal with | [ H : isType _ _ T |- _ ] => exact H end : pcuic. -Ltac unfold_pcuic := +Ltac unfold_pcuic := progress (unfold PCUICTypingDef.typing, PCUICLookup.wf_universe in * ). #[global] Hint Extern 10 => unfold_pcuic : pcuic. @@ -186,7 +186,7 @@ Ltac pcuics := try typeclasses eauto with pcuic. Lemma declared_projection_declared_constructor {cf} {Σ} {wfΣ : wf Σ} {p mdecl mdecl' idecl idecl' pdecl cdecl cdecl'} : declared_projection Σ p mdecl idecl cdecl pdecl -> - declared_constructor Σ (p.(proj_ind), 0) mdecl' idecl' cdecl' -> + declared_constructor Σ (p.(proj_ind), 0) mdecl' idecl' cdecl' -> mdecl = mdecl' /\ idecl = idecl' /\ cdecl = cdecl'. Proof. intros [[] ?] []. @@ -199,7 +199,7 @@ Ltac hide H := | ?ty => change ty with (@hidebody _ ty) in H end. -Lemma All2i_nth_error {A B} {P : nat -> A -> B -> Type} {l l' n x c k} : +Lemma All2i_nth_error {A B} {P : nat -> A -> B -> Type} {l l' n x c k} : All2i P k l l' -> nth_error l n = Some x -> nth_error l' n = Some c -> @@ -213,7 +213,7 @@ Proof. now rewrite Nat.add_succ_r. Qed. -Lemma conv_context_smash_end {cf Σ} {wfΣ : wf Σ} (Γ Δ Δ' : context) : +Lemma conv_context_smash_end {cf Σ} {wfΣ : wf Σ} (Γ Δ Δ' : context) : wf_local Σ (Γ ,,, Δ) -> wf_local Σ (Γ ,,, Δ') -> Σ ⊢ Γ ,,, Δ = Γ ,,, Δ' -> @@ -225,27 +225,27 @@ Proof. eapply ws_cumul_ctx_pb_rel_smash => //. Qed. -Lemma expand_lets_eq Γ t : - expand_lets Γ t = +Lemma expand_lets_eq Γ t : + expand_lets Γ t = subst0 (extended_subst Γ 0) (lift (context_assumptions Γ) #|Γ| t). Proof. rewrite /expand_lets /expand_lets_k /= //. Qed. -Lemma expand_lets_eq_map Γ l : - map (expand_lets Γ) l = +Lemma expand_lets_eq_map Γ l : + map (expand_lets Γ) l = map (subst0 (extended_subst Γ 0)) (map (lift (context_assumptions Γ) #|Γ|) l). Proof. rewrite /expand_lets /expand_lets_k /= map_map_compose //. Qed. -Lemma map_expand_lets_to_extended_list Γ : +Lemma map_expand_lets_to_extended_list Γ : map (expand_lets Γ) (to_extended_list Γ) = to_extended_list (smash_context [] Γ). Proof. now rewrite expand_lets_eq_map map_subst_extended_subst_lift_to_extended_list_k. Qed. -Lemma conv_context_rel_reln {cf} {Σ} {le} Γ Δ Δ' : +Lemma conv_context_rel_reln {cf} {Σ} {le} Γ Δ Δ' : ws_cumul_ctx_pb_rel le Σ Γ Δ Δ' -> forall acc n, reln acc n Δ = reln acc n Δ'. Proof. @@ -253,8 +253,8 @@ Proof. - constructor. - intros acc n; destruct p; simpl; auto. Qed. - -Lemma conv_context_rel_to_extended_list {cf} {Σ} {le} {Γ Δ Δ'} : + +Lemma conv_context_rel_to_extended_list {cf} {Σ} {le} {Γ Δ Δ'} : ws_cumul_ctx_pb_rel le Σ Γ Δ Δ' -> to_extended_list Δ = to_extended_list Δ'. Proof. @@ -264,7 +264,7 @@ Qed. Require Import PCUICOnFreeVars. -Lemma eq_context_alpha_conv {cf} {Σ} {wfΣ : wf Σ} Γ Δ Δ' : +Lemma eq_context_alpha_conv {cf} {Σ} {wfΣ : wf Σ} Γ Δ Δ' : eq_context_upto_names Δ Δ' -> is_closed_context (Γ ,,, Δ) -> is_closed_context (Γ ,,, Δ') -> @@ -272,7 +272,7 @@ Lemma eq_context_alpha_conv {cf} {Σ} {wfΣ : wf Σ} Γ Δ Δ' : Proof. induction 1. - constructor; auto. constructor. - - rewrite /= !on_free_vars_ctx_snoc => /andP[] cl; + - rewrite /= !on_free_vars_ctx_snoc => /andP[] cl; generalize cl; rewrite on_free_vars_ctx_app => /andP[] clΓ cll clx /andP[] clΓ' cly. intros; destruct r; constructor => //. * constructor. apply IHX => //. constructor; auto; subst. @@ -283,10 +283,10 @@ Proof. move/andP: cly => /= [clb' clty']. constructor; auto; subst. eapply into_ws_cumul_pb; eauto. - eapply into_ws_cumul_pb; eauto. + eapply into_ws_cumul_pb; eauto. Qed. -Lemma eq_context_alpha_reln Δ Δ' : +Lemma eq_context_alpha_reln Δ Δ' : eq_context_upto_names Δ Δ' -> forall acc n, reln acc n Δ = reln acc n Δ'. Proof. @@ -295,7 +295,7 @@ Proof. - intros acc n; destruct r; simpl; auto. Qed. -Lemma eq_context_alpha_to_extended_list Δ Δ' : +Lemma eq_context_alpha_to_extended_list Δ Δ' : eq_context_upto_names Δ Δ' -> to_extended_list Δ = to_extended_list Δ'. Proof. @@ -303,7 +303,7 @@ Proof. intros; now eapply eq_context_alpha_reln. Qed. -Lemma reln_set_binder_name brctx Γ : +Lemma reln_set_binder_name brctx Γ : All2 (fun (x : binder_annot name) (y : context_decl) => eq_binder_annot x (decl_name y)) brctx Γ -> forall acc n, reln acc n (map2 set_binder_name brctx Γ) = reln acc n Γ. @@ -314,7 +314,7 @@ Proof. destruct hd as [na [b|] ty]; cbn; apply IHbrctx; congruence. Qed. -Lemma to_extended_list_set_binder_name brctx Γ : +Lemma to_extended_list_set_binder_name brctx Γ : All2 (fun (x : binder_annot name) (y : context_decl) => eq_binder_annot x (decl_name y)) brctx Γ -> to_extended_list_k (map2 set_binder_name brctx Γ) =1 to_extended_list_k Γ. @@ -333,14 +333,14 @@ Proof. rewrite to_extended_list_set_binder_name //; try by rewrite to_extended_list_k_subst /expand_lets_ctx /expand_lets_k_ctx; substu; rewrite to_extended_list_k_subst - to_extended_list_k_lift_context to_extended_list_k_subst + to_extended_list_k_lift_context to_extended_list_k_subst PCUICLiftSubst.map_subst_instance_to_extended_list_k //. induction hlen; cbn. constructor. rewrite subst_context_snoc /= expand_lets_ctx_snoc subst_context_snoc. constructor. now cbn. apply IHhlen. Qed. -Lemma spine_subst_inst_subst {cf} {Σ} {Γ inst s Δ Δ'} : +Lemma spine_subst_inst_subst {cf} {Σ} {Γ inst s Δ Δ'} : spine_subst Σ Γ inst s Δ -> subst_context s 0 Δ' = subst_context (List.rev inst) 0 (expand_lets_ctx Δ Δ'). Proof. @@ -355,7 +355,7 @@ Proof. apply context_subst_subst_extended_subst. apply sp. Qed. -Lemma spine_subst_inst_subst_term {cf} {Σ} {Γ inst s Δ Δ'} : +Lemma spine_subst_inst_subst_term {cf} {Σ} {Γ inst s Δ Δ'} : spine_subst Σ Γ inst s Δ -> subst s 0 Δ' = subst (List.rev inst) 0 (expand_lets Δ Δ'). Proof. @@ -369,18 +369,18 @@ Proof. rewrite map_rev. rewrite H. apply context_subst_subst_extended_subst. apply sp. Qed. - + Lemma subst_context_subst_context s k s' Γ : subst_context s k (subst_context s' k Γ) = subst_context (map (subst0 s) s') k (subst_context s (k + #|s'|) Γ). Proof. - induction Γ as [|[na [b|] ty] Γ']; simpl; auto; - rewrite !subst_context_snoc /= /subst_decl /map_decl /=; f_equal; - auto; f_equal; len; + induction Γ as [|[na [b|] ty] Γ']; simpl; auto; + rewrite !subst_context_snoc /= /subst_decl /map_decl /=; f_equal; + auto; f_equal; len; rewrite -{1}(Nat.add_0_r (#|Γ'| + k)) distr_subst_rec; lia_f_equal. Qed. -Lemma spine_subst_inst_subst_k {cf} {Σ} {Γ inst s Δ k Δ'} : +Lemma spine_subst_inst_subst_k {cf} {Σ} {Γ inst s Δ k Δ'} : spine_subst Σ Γ inst s Δ -> subst_context s k Δ' = subst_context (List.rev inst) k (expand_lets_k_ctx Δ k Δ'). Proof. @@ -395,7 +395,7 @@ Proof. apply context_subst_subst_extended_subst. apply sp. Qed. -Lemma spine_subst_inst_subst_term_k {cf} {Σ} {Γ inst s Δ k Δ'} : +Lemma spine_subst_inst_subst_term_k {cf} {Σ} {Γ inst s Δ k Δ'} : spine_subst Σ Γ inst s Δ -> subst s k Δ' = subst (List.rev inst) k (expand_lets_k Δ k Δ'). Proof. @@ -410,9 +410,9 @@ Proof. apply context_subst_subst_extended_subst. apply sp. Qed. -Lemma isType_weaken {cf} {Σ Γ Δ T} {wfΣ : wf Σ} : - wf_local Σ Δ -> - isType Σ Γ T -> +Lemma isType_weaken {cf} {Σ Γ Δ T} {wfΣ : wf Σ} : + wf_local Σ Δ -> + isType Σ Γ T -> isType Σ (Δ ,,, Γ) T. Proof. intros wfΔ HT. @@ -420,7 +420,7 @@ Proof. eapply weaken_ctx => //. Qed. -(** The crucial property on constructors of cumulative inductive types for type preservation: +(** The crucial property on constructors of cumulative inductive types for type preservation: we don't need to compare their instances when fully applied. *) Lemma R_global_instance_cstr_irrelevant {cf} {Σ} {wfΣ : wf Σ} {ci c} {mdecl idecl cdecl u u'} : declared_constructor Σ (ci, c) mdecl idecl cdecl -> @@ -454,12 +454,12 @@ Proof. eapply pre_case_branch_context_eq; eauto. Qed. -Lemma conv_refl' {cf} {Σ} {wfΣ : wf Σ} {Γ x y} : +Lemma conv_refl' {cf} {Σ} {wfΣ : wf Σ} {Γ x y} : x = y -> Σ ;;; Γ |- x = y. Proof. now intros ->. Qed. -Lemma expand_lets_lift_cancel Γ x : +Lemma expand_lets_lift_cancel Γ x : expand_lets Γ (lift0 #|Γ| x) = lift0 (context_assumptions Γ) x. Proof. rewrite /expand_lets /expand_lets_k. @@ -491,20 +491,20 @@ Proof. now rewrite Nat.add_comm. Qed. -Lemma smash_context_subst_context_let_expand s Γ Δ : - smash_context [] (subst_context_let_expand s Γ Δ) = +Lemma smash_context_subst_context_let_expand s Γ Δ : + smash_context [] (subst_context_let_expand s Γ Δ) = subst_context_let_expand s Γ (smash_context [] Δ). Proof. rewrite /subst_context_let_expand. rewrite (smash_context_subst []). - now rewrite /expand_lets_ctx /expand_lets_k_ctx (smash_context_subst []) + now rewrite /expand_lets_ctx /expand_lets_k_ctx (smash_context_subst []) (smash_context_lift []). Qed. Lemma on_constructor_wf_args {cf} {Σ} {wfΣ : wf Σ} {ind c mdecl idecl cdecl u} : declared_constructor Σ (ind, c) mdecl idecl cdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> - wf_local Σ (subst_instance u (ind_params mdecl) ,,, + wf_local Σ (subst_instance u (ind_params mdecl) ,,, (subst_context (ind_subst mdecl ind u)) #|ind_params mdecl| (subst_instance u (cstr_args cdecl))). Proof. intros decl cu. @@ -524,7 +524,7 @@ Instance conv_context_refl {cf} Σ {wfΣ : wf Σ} : CRelationClasses.Reflexive ( Proof. intros x. reflexivity. Qed. - + (* Instance conv_context_sym {cf} Σ {wfΣ : wf Σ} : CRelationClasses.Symmetric (All2_fold (conv_decls Σ)). Proof. intros x y. now apply conv_context_sym. @@ -581,7 +581,7 @@ Proof. depelim a; cbn in *; constructor; auto; eapply (ws_cumul_pb_ws_cumul_ctx (pb':=Conv)); tea. Qed. - + Lemma OnOne2_All2_All2 {A B : Type} {l1 l2 : list A} {l3 : list B} {R1 : A -> A -> Type} {R2 R3 : A -> B -> Type} : OnOne2 R1 l1 l2 -> All2 R2 l1 l3 -> @@ -616,7 +616,7 @@ Proof. Qed. (* Lemma conv_context_set_binder_name {cf} {Σ} {wfΣ : wf Σ} {Δ nas Γ Γ'} : - All2 (fun na decl => eq_binder_annot na decl.(decl_name)) nas Γ -> + All2 (fun na decl => eq_binder_annot na decl.(decl_name)) nas Γ -> conv_context_rel Σ Δ Γ Γ' -> conv_context_rel Σ Δ Γ (map2 set_binder_name nas Γ'). Proof. @@ -633,7 +633,7 @@ Proof. Qed. *) (* Lemma conv_context_set_binder_name_inv {cf} {Σ} {wfΣ : wf Σ} {Δ nas Γ Γ'} : - All2 (fun na decl => eq_binder_annot na decl.(decl_name)) nas Γ' -> + All2 (fun na decl => eq_binder_annot na decl.(decl_name)) nas Γ' -> conv_context_rel Σ Δ Γ (map2 set_binder_name nas Γ') -> conv_context_rel Σ Δ Γ Γ'. Proof. @@ -649,7 +649,7 @@ Proof. now transitivity x. Qed. *) -Lemma OnOne2_local_env_forget_types P ctx ctx' : +Lemma OnOne2_local_env_forget_types P ctx ctx' : OnOne2_local_env (on_one_decl P) ctx ctx' -> forget_types ctx = forget_types ctx'. Proof. @@ -659,10 +659,10 @@ Proof. - f_equal; auto. Qed. -(* Lemma OnOne2_local_env_All Σ P Q R ctx ctx' : +(* Lemma OnOne2_local_env_All Σ P Q R ctx ctx' : OnOne2_local_env (on_one_decl P) ctx ctx' -> - All_local_env (lift_typing Q Σ) ctx -> - (forall Γ t t' ty, All_local_env (lift_typing R Σ) Γ -> + All_local_env (lift_typing Q Σ) ctx -> + (forall Γ t t' ty, All_local_env (lift_typing R Σ) Γ -> lift_typing Q Σ Γ t ty -> P Γ t t' -> lift_typing R Σ Γ t' ty) -> (forall Γ, All_local_env (lift_typing Q Σ) Γ -> All_local_env (lift_typing R Σ) Γ) -> All_local_env (lift_typing R Σ) ctx'. @@ -674,19 +674,19 @@ Proof. specialize (H Γ t t' (Some (tSort s))). simpl in H. eauto. - depelim p; subst; auto. depelim a. destruct l as [s' Hs]. - intros IH. + intros IH. destruct s as [[? <-]|[? <-]]; subst; constructor; auto. specialize (H Γ t t' None). eapply H; eauto. now exists s'. specialize (H Γ b b (Some t')). eapply H; eauto. now exists s'. - + exists s'; eauto. specialize (H Γ t' b t). eapply H. eauto. exact Hs. - f_equal; auto. Qed. *) From MetaCoq.PCUIC Require Import PCUICContextReduction PCUICOnFreeVars. -(* Lemma red_one_decl_conv_context {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : +(* Lemma red_one_decl_conv_context {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : OnOne2_local_env (on_one_decl (fun Δ : context => red1 Σ (Γ ,,, Δ))) Δ Δ' -> conv_context Σ (Γ ,,, Δ) (Γ ,,, Δ'). Proof. @@ -698,7 +698,7 @@ Proof. constructor. exact o. Qed. *) -Lemma red_one_decl_red_ctx {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : +Lemma red_one_decl_red_ctx {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : is_closed_context (Γ ,,, Δ) -> OnOne2_local_env (on_one_decl (fun Δ : context => red1 Σ (Γ ,,, Δ))) Δ Δ' -> red_ctx Σ (Γ ,,, Δ) (Γ ,,, Δ'). @@ -712,7 +712,7 @@ Proof. constructor. exact o. Qed. -Lemma into_closed_red_ctx {cf} {Σ} {wfΣ : wf Σ} {Γ Δ} : +Lemma into_closed_red_ctx {cf} {Σ} {wfΣ : wf Σ} {Γ Δ} : is_closed_context Γ -> red_ctx Σ Γ Δ -> closed_red_ctx Σ Γ Δ. @@ -730,7 +730,7 @@ Proof. now eapply on_free_vars_ctx_All_fold in IH. Qed. -Lemma red_one_decl_red_context {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : +Lemma red_one_decl_red_context {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : is_closed_context (Γ ,,, Δ) -> OnOne2_local_env (on_one_decl (fun Δ : context => red1 Σ (Γ ,,, Δ))) Δ Δ' -> Σ ⊢ Γ ,,, Δ ⇝ Γ ,,, Δ'. @@ -740,7 +740,7 @@ Proof. now apply red_one_decl_red_ctx. Qed. -Lemma red_one_decl_ws_cumul_ctx_pb {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : +Lemma red_one_decl_ws_cumul_ctx_pb {cf} {Σ} {wfΣ : wf Σ} {Γ Δ Δ'} : is_closed_context (Γ ,,, Δ) -> OnOne2_local_env (on_one_decl (fun Δ : context => red1 Σ (Γ ,,, Δ))) Δ Δ' -> Σ ⊢ Γ ,,, Δ = Γ ,,, Δ'. @@ -776,7 +776,7 @@ Proof. eapply conv_context_rel_app. reflexivity. eapply All2_rev. eapply OnOne2_All2; tea. intros. now eapply red_conv, red1_red. reflexivity. - all:tea. + all:tea. Qed. *) Lemma ctx_inst_merge {cf} {Σ} {wfΣ : wf Σ} Γ inst inst' Δ : @@ -794,7 +794,7 @@ Proof. - depelim o. constructor. apply t0. auto. rewrite -(List.rev_involutive Δ). rewrite subst_telescope_subst_context. - simpl in wf. rewrite - !/(app_context _ _) app_context_assoc in wf. + simpl in wf. rewrite - !/(app_context _ _) app_context_assoc in wf. eapply ctx_inst_cumul. 2:{ instantiate (1:=subst_context [i] 0 (List.rev Δ)). rewrite -subst_telescope_subst_context List.rev_involutive. exact ctxi. } @@ -860,7 +860,7 @@ Qed. Ltac forward_keep H := match type of H with ?X -> _ => - let H' := fresh in + let H' := fresh in assert (H' : X) ; [|specialize (H H')] end. (** The subject reduction property of the system: *) @@ -871,11 +871,11 @@ Definition SR_red1 {cf} Σ Γ t T := match goal with | [ H : is_true (on_free_vars_decl _ _) |- _ ] => progress cbn in H | [ H : is_true (on_free_vars_decl _ (vdef _ _ _)) |- _ ] => unfold on_free_vars_decl, test_decl in H - | [ H : is_true (_ && _) |- _ ] => + | [ H : is_true (_ && _) |- _ ] => move/andP: H => []; intros - | [ H : is_true (on_free_vars ?P ?t) |- _ ] => + | [ H : is_true (on_free_vars ?P ?t) |- _ ] => progress (cbn in H || rewrite on_free_vars_mkApps in H); - (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || + (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || eapply forallb_All in H); intros | [ H : is_true (test_def (on_free_vars ?P) ?Q ?x) |- _ ] => move/andP: H => []; rewrite ?shiftnP_xpredT; intros @@ -926,7 +926,7 @@ Lemma closed_red1_ind (Σ : global_env_ext) (P0 : context -> term -> term -> Typ closed_red1 Σ Γ M M' -> P0 Γ M M' -> P Γ (tLambda na M N) (tLambda na M' N)) -> (forall (Γ : context) (na : aname) (M M' N : term), - closed_red1 Σ (Γ,, vass na N) M M' -> P0 (Γ,, vass na N) M M' -> + closed_red1 Σ (Γ,, vass na N) M M' -> P0 (Γ,, vass na N) M M' -> P Γ (tLambda na N M) (tLambda na N M')) -> (forall (Γ : context) (na : aname) (b t b' r : term), @@ -953,18 +953,18 @@ Lemma closed_red1_ind (Σ : global_env_ext) (P0 : context -> term -> term -> Typ P0 (Γ ,,, inst_case_predicate_context p) p.(preturn) preturn' -> P Γ (tCase ci p c brs) (tCase ci (set_preturn p preturn') c brs)) -> - + (forall (Γ : context) (ind : case_info) (p : predicate term) (c c' : term) (brs : list (branch term)), closed_red1 Σ Γ c c' -> P0 Γ c c' -> P Γ (tCase ind p c brs) (tCase ind p c' brs)) -> (forall (Γ : context) ci p c brs brs', OnOne2 (fun br br' => - (on_Trel_eq (Trel_conj (closed_red1 Σ (Γ ,,, inst_case_branch_context p br)) + (on_Trel_eq (Trel_conj (closed_red1 Σ (Γ ,,, inst_case_branch_context p br)) (P0 (Γ ,,, inst_case_branch_context p br))) bbody bcontext br br')) brs brs' -> P Γ (tCase ci p c brs) (tCase ci p c brs')) -> - (forall (Γ : context) (p : projection) (c c' : term), + (forall (Γ : context) (p : projection) (c c' : term), closed_red1 Σ Γ c c' -> P0 Γ c c' -> P Γ (tProj p c) (tProj p c')) -> @@ -972,21 +972,21 @@ Lemma closed_red1_ind (Σ : global_env_ext) (P0 : context -> term -> term -> Typ closed_red1 Σ Γ M1 N1 -> P0 Γ M1 N1 -> P Γ (tApp M1 M2) (tApp N1 M2)) -> - (forall (Γ : context) (M2 N2 : term) (M1 : term), + (forall (Γ : context) (M2 N2 : term) (M1 : term), closed_red1 Σ Γ M2 N2 -> P0 Γ M2 N2 -> P Γ (tApp M1 M2) (tApp M1 N2)) -> (forall (Γ : context) (na : aname) (M1 M2 N1 : term), - closed_red1 Σ Γ M1 N1 -> P0 Γ M1 N1 -> + closed_red1 Σ Γ M1 N1 -> P0 Γ M1 N1 -> P Γ (tProd na M1 M2) (tProd na N1 M2)) -> (forall (Γ : context) (na : aname) (M2 N2 M1 : term), - closed_red1 Σ (Γ,, vass na M1) M2 N2 -> - P0 (Γ,, vass na M1) M2 N2 -> + closed_red1 Σ (Γ,, vass na M1) M2 N2 -> + P0 (Γ,, vass na M1) M2 N2 -> P Γ (tProd na M1 M2) (tProd na M1 N2)) -> (forall (Γ : context) (ev : nat) (l l' : list term), - OnOne2 (Trel_conj (closed_red1 Σ Γ) (P0 Γ)) l l' -> + OnOne2 (Trel_conj (closed_red1 Σ Γ) (P0 Γ)) l l' -> P Γ (tEvar ev l) (tEvar ev l')) -> (forall (Γ : context) (mfix0 mfix1 : list (def term)) (idx : nat), @@ -1008,20 +1008,20 @@ Lemma closed_red1_ind (Σ : global_env_ext) (P0 : context -> term -> term -> Typ (P0 (Γ ,,, fix_context mfix0))) dbody (fun x => (dname x, dtype x, rarg x))) mfix0 mfix1 -> P Γ (tCoFix mfix0 idx) (tCoFix mfix1 idx)) -> - + forall (Γ : context) (t t0 : term), closed_red1 Σ Γ t t0 -> P0 Γ t t0. Proof. intros. destruct X27 as [clΓ clt r]. move: clΓ clt. Ltac t := - eauto; try split; eauto; + eauto; try split; eauto; try apply on_free_vars_ctx_snoc_ass => //; try apply on_free_vars_ctx_snoc_def => //; try apply is_open_term_snoc => //; repeat (try inv_on_free_vars; eauto with fvs; cbn). induction r using red1_ind_all; intros; - try solve [multimatch goal with + try solve [multimatch goal with | H : _ |- _ => eapply H end; t]. - eapply X13. 2-3:t. @@ -1063,7 +1063,7 @@ Proof. forward_keep p. { rewrite on_free_vars_ctx_app clΓ /=. eapply on_free_vars_fix_context; trea; t. } - forward_keep p. { + forward_keep p. { rewrite app_length fix_context_length -shiftnP_add //. now inv_on_free_vars. } intuition auto. split; auto. @@ -1078,17 +1078,17 @@ Proof. forward_keep p. { rewrite on_free_vars_ctx_app clΓ /=. eapply on_free_vars_fix_context; trea; t. } - forward_keep p. { + forward_keep p. { rewrite app_length fix_context_length -shiftnP_add //. now inv_on_free_vars. } intuition auto. split; auto. Qed. -Definition closed_red1_ind' := - ltac:(let T := type of closed_red1_ind in - let T' := eval cbn in T in +Definition closed_red1_ind' := + ltac:(let T := type of closed_red1_ind in + let T' := eval cbn in T in exact (closed_red1_ind : T')). -(* +(* Ltac revert_until x := repeat lazymatch goal with | [ H : _ |- _ ] => revert H @@ -1112,31 +1112,31 @@ Proof. now apply subject_closed in X; apply closedn_on_free_vars. Qed. -Lemma ws_cumul_pb_meta_refl {cf} {Σ} {wfΣ : wf Σ} {Γ T U} : +Lemma ws_cumul_pb_meta_refl {cf} {Σ} {wfΣ : wf Σ} {Γ T U} : is_closed_context Γ -> closedn #|Γ| T -> T = U -> Σ ;;; Γ ⊢ T = U. Proof. intros clΓ cl ->. apply ws_cumul_pb_refl => //. now apply closedn_on_free_vars. Qed. -Lemma ws_cumul_pb_eq_trans {cf} {Σ} {wfΣ : wf Σ} {Γ T U V} : +Lemma ws_cumul_pb_eq_trans {cf} {Σ} {wfΣ : wf Σ} {Γ T U V} : Σ ;;; Γ ⊢ T = U -> U = V -> Σ ;;; Γ ⊢ T = V. Proof. now intros tr ->. Qed. -Lemma eq_ws_cumul_pb_trans {cf} {Σ} {wfΣ : wf Σ} {Γ T U V} : +Lemma eq_ws_cumul_pb_trans {cf} {Σ} {wfΣ : wf Σ} {Γ T U V} : T = U -> Σ ;;; Γ ⊢ U = V -> Σ ;;; Γ ⊢ T = V. Proof. now intros -> tr. Qed. -Lemma ws_cumul_pb_terms_eq_trans {cf} {Σ} {wfΣ : wf Σ} {Γ T U V} : +Lemma ws_cumul_pb_terms_eq_trans {cf} {Σ} {wfΣ : wf Σ} {Γ T U V} : ws_cumul_pb_terms Σ Γ T U -> U = V -> ws_cumul_pb_terms Σ Γ T V. Proof. now intros tr ->. Qed. -Lemma eq_ws_cumul_pb_terms_trans {cf} {Σ} {wfΣ : wf Σ} {Γ T U V} : +Lemma eq_ws_cumul_pb_terms_trans {cf} {Σ} {wfΣ : wf Σ} {Γ T U V} : T = U -> ws_cumul_pb_terms Σ Γ U V -> ws_cumul_pb_terms Σ Γ T V. Proof. now intros -> tr. @@ -1154,7 +1154,7 @@ Qed. Local Notation welltyped Σ Γ t := (∑ T, Σ ;;; Γ |- t : T). Local Notation welltyped_terms Σ Γ := (All (fun t => welltyped Σ Γ t)). -Lemma spine_subst_wt_terms {cf} {Σ Γ inst s Δ} : spine_subst Σ Γ inst s Δ -> +Lemma spine_subst_wt_terms {cf} {Σ Γ inst s Δ} : spine_subst Σ Γ inst s Δ -> welltyped_terms Σ Γ inst. Proof. move/spine_subst_ctx_inst. @@ -1187,7 +1187,7 @@ Proof. apply weakening_ws_cumul_pb => //; fvs. Qed. -Lemma on_constructor_closed_indices {cf} {Σ} {wfΣ : wf Σ} : +Lemma on_constructor_closed_indices {cf} {Σ} {wfΣ : wf Σ} : forall {i mdecl idecl cdecl}, declared_constructor Σ.1 i mdecl idecl cdecl -> All (is_open_term (arities_context (ind_bodies mdecl) ,,, ind_params mdecl ,,, cstr_args cdecl)) (cstr_indices cdecl). @@ -1254,9 +1254,9 @@ Qed. Arguments pair {A B}%type_scope &. -Lemma ws_cumul_pb_terms_refl {cf} {Σ} {wfΣ : wf Σ} {Γ u} : +Lemma ws_cumul_pb_terms_refl {cf} {Σ} {wfΣ : wf Σ} {Γ u} : is_closed_context Γ -> - forallb (is_open_term Γ) u -> + forallb (is_open_term Γ) u -> ws_cumul_pb_terms Σ Γ u u. Proof. intros. eapply into_ws_cumul_pb_terms => //. @@ -1269,7 +1269,7 @@ Proof. now repeat constructor. Qed. Lemma map2_set_binder_name_expand_lets nas Γ Δ : #|nas| = #|Δ| -> - map2 set_binder_name nas (expand_lets_ctx Γ Δ) = + map2 set_binder_name nas (expand_lets_ctx Γ Δ) = expand_lets_ctx Γ (map2 set_binder_name nas Δ). Proof. move=> hlen. @@ -1278,7 +1278,7 @@ Proof. rewrite PCUICRenameConv.map2_set_binder_name_fold ?lengths //. Qed. -Lemma closed_red1_eq_context_upto_names {Σ Γ Γ'} {t u} : +Lemma closed_red1_eq_context_upto_names {Σ Γ Γ'} {t u} : eq_context_upto_names Γ Γ' → closed_red1 Σ Γ t u → closed_red1 Σ Γ' t u. Proof. intros eqctx []; split; auto. @@ -1286,12 +1286,12 @@ Proof. - now rewrite -(All2_length eqctx). - eapply red1_eq_context_upto_names; tea. Qed. - -Lemma closed_red1_ws_cumul_pb {cf} {Σ} {wfΣ : wf Σ} {Γ} {t u} : + +Lemma closed_red1_ws_cumul_pb {cf} {Σ} {wfΣ : wf Σ} {Γ} {t u} : closed_red1 Σ Γ t u -> ws_cumul_pb Conv Σ Γ t u. Proof. intros cl. now eapply red_conv, closed_red1_red. -Qed. +Qed. Notation "Σ ;;; Γ ⊢ t ⇝1 u" := (closed_red1 Σ Γ t u) (at level 50, Γ, t, u at next level, format "Σ ;;; Γ ⊢ t ⇝1 u"). @@ -1299,20 +1299,20 @@ Notation "Σ ;;; Γ ⊢ t ⇝1 u" := (closed_red1 Σ Γ t u) (at level 50, Γ, t Lemma on_free_vars_ctx_tip P d : on_free_vars_ctx P [d] = on_free_vars_decl P d. Proof. cbn; rewrite andb_true_r // shiftnP0 //. Qed. -Lemma on_free_vars_it_mkLambda_or_LetIn {P Δ t} : - on_free_vars P (it_mkLambda_or_LetIn Δ t) = +Lemma on_free_vars_it_mkLambda_or_LetIn {P Δ t} : + on_free_vars P (it_mkLambda_or_LetIn Δ t) = on_free_vars_ctx P Δ && on_free_vars (shiftnP #|Δ| P) t. Proof. move: P. induction Δ using rev_ind => P. - cbn. now rewrite shiftnP0. - destruct x as [na [b|] ty]; rewrite it_mkLambda_or_LetIn_app /= /mkLambda_or_LetIn /=. - rewrite on_free_vars_ctx_app /= IHΔ !lengths /= shiftnP_add on_free_vars_ctx_tip /= + rewrite on_free_vars_ctx_app /= IHΔ !lengths /= shiftnP_add on_free_vars_ctx_tip /= /on_free_vars_decl /test_decl /=. ring. - rewrite on_free_vars_ctx_app /= IHΔ !lengths /= shiftnP_add on_free_vars_ctx_tip /= + rewrite on_free_vars_ctx_app /= IHΔ !lengths /= shiftnP_add on_free_vars_ctx_tip /= /on_free_vars_decl /test_decl /=. ring. Qed. -Lemma closed_red1_it_mkLambda_or_LetIn {cf} {Σ} {wfΣ : wf Σ} {Γ} {Δ t u} : +Lemma closed_red1_it_mkLambda_or_LetIn {cf} {Σ} {wfΣ : wf Σ} {Γ} {Δ t u} : Σ ;;; Γ ,,, Δ ⊢ t ⇝1 u -> Σ ;;; Γ ⊢ it_mkLambda_or_LetIn Δ t ⇝1 it_mkLambda_or_LetIn Δ u. Proof. intros [clΓΔ opt r]. @@ -1321,11 +1321,11 @@ Proof. - rewrite on_free_vars_it_mkLambda_or_LetIn. rewrite on_free_vars_ctx_app in clΓΔ. move/andP: clΓΔ => []. rewrite shiftnP_add -app_length opt andb_true_r //. - - now eapply red1_it_mkLambda_or_LetIn. + - now eapply red1_it_mkLambda_or_LetIn. Qed. -Lemma closed_red1_mkApps_left {cf} {Σ} {wfΣ : wf Σ} {Γ} {t u ts} : - Σ ;;; Γ ⊢ t ⇝1 u -> +Lemma closed_red1_mkApps_left {cf} {Σ} {wfΣ : wf Σ} {Γ} {t u ts} : + Σ ;;; Γ ⊢ t ⇝1 u -> forallb (is_open_term Γ) ts -> Σ ;;; Γ ⊢ mkApps t ts ⇝1 mkApps u ts. Proof. @@ -1353,7 +1353,7 @@ Lemma closed_red1_case_branch_type {cf} {Σ} {wfΣ : wf Σ} {Γ} {ret ret'} {ind wf_branch cdecl br -> is_open_term (Γ ,,, cb.1) cb.2 -> is_closed_context (Γ ,,, cb.1) -> - Σ ;;; Γ ⊢ ret ⇝1 ret' -> + Σ ;;; Γ ⊢ ret ⇝1 ret' -> Σ ;;; Γ ,,, cb.1 ⊢ cb.2 ⇝1 cb'.2. Proof. intros cb cb' wfbr op r. @@ -1392,8 +1392,8 @@ Proof. induction Γ as [|[? [] ?] ?]; intros; cbn; lia. Qed. -Lemma declared_projection_indices {cf} {Σ} {wfΣ : wf Σ} {p mdecl idecl cdecl pdecl} : - declared_projection Σ p mdecl idecl cdecl pdecl -> +Lemma declared_projection_indices {cf} {Σ} {wfΣ : wf Σ} {p mdecl idecl cdecl pdecl} : + declared_projection Σ p mdecl idecl cdecl pdecl -> #|ind_indices idecl| = 0. Proof. move=> isdecl. @@ -1429,7 +1429,7 @@ Proof. now eapply wf_local_app_skipn. Qed. -Lemma isType_subst_arities {cf} {Σ} {wfΣ : wf Σ} {ind mdecl idecl u} {Γ T} : +Lemma isType_subst_arities {cf} {Σ} {wfΣ : wf Σ} {ind mdecl idecl u} {Γ T} : declared_inductive Σ ind mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> isType Σ ((arities_context (ind_bodies mdecl))@[u] ,,, Γ) T -> @@ -1441,7 +1441,7 @@ Proof. rewrite app_context_nil_l //. Qed. -Lemma wt_closed_red1 {cf} {Σ} {wfΣ : wf Σ} {Γ T U} : +Lemma wt_closed_red1 {cf} {Σ} {wfΣ : wf Σ} {Γ T U} : welltyped Σ Γ T -> red1 Σ Γ T U -> Σ ;;; Γ ⊢ T ⇝1 U. @@ -1452,7 +1452,7 @@ Proof. now eapply subject_is_open_term in HT. Qed. -Lemma isType_expand_lets {cf} {Σ} {wfΣ : wf Σ} {Γ Δ T} : +Lemma isType_expand_lets {cf} {Σ} {wfΣ : wf Σ} {Γ Δ T} : isType Σ (Γ ,,, Δ) T -> isType Σ (smash_context [] Γ ,,, expand_lets_ctx Γ Δ) (expand_lets_k Γ #|Δ| T). Proof. @@ -1462,7 +1462,7 @@ Proof. now exists s. Qed. -Lemma isType_subst_extended_subst {cf} {Σ} {wfΣ : wf Σ} {Γ Δ T} : +Lemma isType_subst_extended_subst {cf} {Σ} {wfΣ : wf Σ} {Γ Δ T} : isType Σ (Γ ,,, Δ) T -> isType Σ (smash_context [] Γ ,,, subst_context (extended_subst Γ 0) 0 Δ) (subst (extended_subst Γ 0) #|Δ| T). @@ -1507,7 +1507,7 @@ Proof. Qed. Lemma type_Cumul_alt {cf} {Σ} {wfΣ : wf Σ} (Γ : context) (t T T' : term) : - Σ;;; Γ |- t : T → isType Σ Γ T' → + Σ;;; Γ |- t : T → isType Σ Γ T' → Σ;;; Γ |- T <= T' → Σ;;; Γ |- t : T'. Proof. intros Ht isty cum. @@ -1517,8 +1517,8 @@ Qed. Lemma sr_red1 {cf:checker_flags} : env_prop SR_red1 - (fun Σ Γ => wf_local Σ Γ × - (forall Γ' Δ' Δ, + (fun Σ Γ => wf_local Σ Γ × + (forall Γ' Δ' Δ, Γ = Γ' ,,, Δ' -> OnOne2_local_env (on_one_decl (fun Δ : context => closed_red1 Σ (Γ',,, Δ))) Δ' Δ -> wf_local_rel Σ Γ' Δ)). @@ -1548,7 +1548,7 @@ Proof. now eapply wf_local_app_inv. apply infer_typing_sort_impl with id tu; intros _. now eapply Hs. - * depelim X. + * depelim X. constructor. now eapply wf_local_app_inv. depelim p. destruct s as [[red <-]|[red <-]]; subst. apply infer_typing_sort_impl with id tu; intros _. @@ -1560,7 +1560,7 @@ Proof. apply Hs. eapply (red_ws_cumul_pb (pb:=Cumul)). now eapply closed_red1_red. now eapply Hc. - + * depelim X; specialize (IHX0 _ X); pose proof (wf_local_closed_context all). + constructor; auto. clear X. pose proof (wf_local_closed_context all). @@ -1570,7 +1570,7 @@ Proof. eapply closed_context_conversion; tea. eapply red_one_decl_ws_cumul_ctx_pb => //. eapply OnOne2_local_env_impl; tea. - intros ???. eapply on_one_decl_impl => ???; firstorder. + intros ???. eapply on_one_decl_impl => ???; firstorder. + constructor; auto. clear X. { eapply wf_local_app_inv in all as []. eapply wf_local_app in IHX0; tea. @@ -1609,7 +1609,7 @@ Proof. intuition auto. unshelve eapply (closed_context_conversion _ typeb); pcuics. constructor. now eapply ws_cumul_ctx_pb_refl, wf_local_closed_context. - constructor; auto. eapply red_conv. now eapply closed_red1_red. + constructor; auto. eapply red_conv. now eapply closed_red1_red. assert (Σ ;;; Γ |- tLambda n t b : tProd n t bty). econstructor; pcuics. now eapply validity in X0. econstructor 3. eapply cumul_refl'. @@ -1619,7 +1619,7 @@ Proof. eapply type_Cumul_alt. apply (@substitution_let _ _ _ Γ n b b_ty b' b'_ty typeb'). specialize (typing_wf_local typeb') as wfd. - assert (Σ ;;; Γ |- tLetIn n b b_ty b' : tLetIn n b b_ty b'_ty). + assert (Σ ;;; Γ |- tLetIn n b b_ty b' : tLetIn n b b_ty b'_ty). econstructor; eauto. eapply (validity X0). eapply cumul_red_r. @@ -1641,7 +1641,7 @@ Proof. eapply type_Cumul_alt. econstructor; eauto. eapply type_Cumul_alt. eauto. exists s1; auto. - apply: red_cumul Hu. + apply: red_cumul Hu. unshelve eapply (closed_context_conversion _ typeb'). constructor; pcuic. eapply type_Cumul_alt. eauto. pcuic. apply: red_cumul Hu. @@ -1677,7 +1677,7 @@ Proof. eapply type_App; eauto. eapply type_mkApps; [|tea]. eapply type_ws_cumul_pb; eauto. - + - (* Application congruence for argument *) intuition auto. eapply type_Cumul_alt; [eapply type_App| |]; eauto with wf. @@ -1691,7 +1691,7 @@ Proof. cbn. now eapply closedn_on_free_vars. constructor. apply: red1_red Hu. constructor. all:repeat constructor. cbn. rewrite -(shiftnP_add 1) addnP_shiftnP. repeat inv_on_free_vars => //. - + - (* Constant unfolding *) unshelve epose proof (declared_constant_inj decl decl0 _ _); tea; subst decl. destruct decl0 as [ty body' univs]; simpl in *; subst body'. @@ -1738,12 +1738,12 @@ Proof. set (pargctxu1 := subst_context cparsubst 0 argctxu1) in X |- *. set (pargctxu := subst_context iparsubst 0 argctxu) in X |- *. destruct X as [cumargs convidx]; eauto. - assert(wfparu : wf_local Σ (subst_instance (puinst p) (ind_params mdecl))). + assert(wfparu : wf_local Σ (subst_instance (puinst p) (ind_params mdecl))). { eapply on_minductive_wf_params; eauto. } assert (wfps : wf_universe Σ ps). { eapply validity in IHp; auto. eapply PCUICWfUniverses.isType_wf_universes in IHp; tea. now apply (ssrbool.elimT PCUICWfUniverses.wf_universe_reflect) in IHp. } - have lenpars := (wf_predicate_length_pars H0). + have lenpars := (wf_predicate_length_pars H0). unfold hidebody in X8. set (ptm := it_mkLambda_or_LetIn _ _). rename c0 into c. @@ -1774,7 +1774,7 @@ Proof. { etransitivity; tea. eapply ws_cumul_ctx_pb_app; revgoals. 3:eapply ws_cumul_ctx_pb_refl; eapply wf_local_closed_context; auto. - split. apply ws_cumul_ctx_pb_refl. pcuic. + split. apply ws_cumul_ctx_pb_refl. pcuic. eapply eq_context_alpha_conv => //. now symmetry. eapply wf_local_closed_context. eapply typing_wf_local in hb. eapply wf_local_alpha; tea. eapply All2_app => //. reflexivity. @@ -1795,7 +1795,7 @@ Proof. { eapply wf_local_smash_end; tea. } assert (wfbrctx' : wf_local Σ (Γ ,,, brctx)). { eapply wf_local_alpha. eapply All2_app; tea. eapply All2_refl; reflexivity. assumption. } - assert (convbrctxsmash : Σ ⊢ + assert (convbrctxsmash : Σ ⊢ Γ ,,, smash_context [] (case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl) = Γ ,,, smash_context [] brctx). { eapply conv_context_smash_end; tea. now symmetry. } @@ -1820,7 +1820,7 @@ Proof. apply ws_cumul_ctx_pb_refl. now apply wf_local_closed_context in prewfs. } eapply closed_context_conversion in hb. - 3:{ symmetry. eapply convbrctx'. } + 3:{ symmetry. eapply convbrctx'. } eapply typing_expand_lets in hb. eapply (PCUICSubstitution.substitution (Δ := [])) in hb. 2:{ eapply (spine_subst_cumul (Γ' := smash_context [] brctx)) in spbrctx; tea. @@ -1829,7 +1829,7 @@ Proof. now apply wf_local_smash_end. apply ws_cumul_ctx_pb_rel_smash => //. apply ws_cumul_ctx_pb_rel_app. apply ws_cumul_ctx_pb_eq_le. symmetry. - etransitivity; tea. } + etransitivity; tea. } rewrite subst_context_nil -heq_ind_npars in hb *. eapply (type_ws_cumul_pb (pb:=Cumul)). exact hb. 3:auto. assumption. clear hb. @@ -1838,8 +1838,8 @@ Proof. (* Move back to the canonical branch context for the rest of the proof *) transitivity (subst0 (List.rev (skipn (ind_npars mdecl) args)) (expand_lets prebrctx cbtyg.2)). { eapply ws_cumul_pb_eq_le. - eapply (substitution_ws_cumul_pb (Γ'' := [])). eapply spbrctx. - symmetry. apply (ws_cumul_pb_expand_lets_ws_cumul_ctx (pb:=Cumul)); tea. + eapply (substitution_ws_cumul_pb (Γ'' := [])). eapply spbrctx. + symmetry. apply (ws_cumul_pb_expand_lets_ws_cumul_ctx (pb:=Cumul)); tea. eapply wt_cumul_pb_refl. rewrite case_branch_type_fst in cbty. eapply closed_context_conversion in cbty. exact cbty. @@ -1872,7 +1872,7 @@ Proof. subst_context (inds (inductive_mind ci) (puinst p) (ind_bodies mdecl)) #|ind_params mdecl| (subst_instance (puinst p) (cstr_args cdecl))). { exact (on_constructor_wf_args declc cu'). } - eapply ws_cumul_pb_mkApps; tea. + eapply ws_cumul_pb_mkApps; tea. { eapply wt_cumul_pb_refl. eapply type_it_mkLambda_or_LetIn; tea. } rewrite firstn_app_left // /= in iparsubst0. rewrite firstn_app_left // /= in Hpars. @@ -1885,7 +1885,7 @@ Proof. apply ctx_inst_open_terms in X0. eapply All_All2; tea. cbn; intros. apply ws_cumul_pb_refl; tea. } - + eapply All2_app. * set(indsub := inds _ _ _). relativize (map (subst0 _) _). @@ -1909,12 +1909,12 @@ Proof. intros cv convidx. eapply (ws_cumul_pb_terms_subst (Δ := [])) in cv. 3:{ exact (spine_subst_smash idxsubst0). } - 3:{ exact (spine_subst_smash idxsubst0). } + 3:{ exact (spine_subst_smash idxsubst0). } all:tea. 2:{ eapply wf_local_closed_context. eapply wf_local_smash_end; tea. eapply idxsubst0. } 2:{ eapply All2_rev => //. } rewrite subst_context_nil /= in cv. simpl in cv. rewrite skipn_all_app_eq // in convidx. - + assert(ws_cumul_pb_terms Σ Γ (map (fun x : term => @@ -1927,7 +1927,7 @@ Proof. eapply All_map_eq, All_impl; tea. cbn; intros x. intros cl. - epose proof + epose proof ( @spine_subst_app _ Σ Γ (subst_instance u (ind_params mdecl)) (subst_context (inds (inductive_mind ci) u (ind_bodies mdecl)) @@ -1935,7 +1935,7 @@ Proof. (firstn (ind_npars mdecl) args) (skipn (ind_npars mdecl) args) (cargsubst ++ cparsubst)) as X3. rewrite lenfirst in X3. len in X3. - specialize (X3 eq_refl). + specialize (X3 eq_refl). forward X3. { rewrite -app_context_assoc. eapply weaken_wf_local; tea. } forward X3. { rewrite skipn_all_app_eq; len. @@ -1964,7 +1964,7 @@ Proof. rewrite closedn_subst_instance_context. eapply (declared_inductive_closed_params isdecl). rewrite subst_instance_length. - eapply (closedn_ctx_subst 0). simpl. + eapply (closedn_ctx_subst 0). simpl. rewrite /ind_subst inds_length. now rewrite closedn_subst_instance_context. eapply (declared_minductive_closed_inds isdecl). @@ -1978,9 +1978,9 @@ Proof. (* rewrite -subst_instance_app_ctx -subst_instance_expand_lets closedn_subst_instance. *) relativize (context_assumptions _). erewrite <-(expand_lets_subst_comm _ _ _). - 2:{ now rewrite /argctxu1 !context_assumptions_app + 2:{ now rewrite /argctxu1 !context_assumptions_app !context_assumptions_subst_context !context_assumptions_subst_instance. } - f_equal. + f_equal. * rewrite subst_context_app closed_ctx_subst. rewrite closedn_subst_instance_context. now apply (declared_inductive_closed_params isdecl). @@ -2013,7 +2013,7 @@ Proof. rewrite -List.rev_app_distr firstn_skipn. len. rewrite lenskip expand_lets_app /argctxu1. rewrite context_assumptions_subst_context context_assumptions_subst_instance //. } - + (* clear -H4 pparamsl wfbrctx convbrctx cumargs wfcbc wfparsargs Hpars lenskip lenfirst lenpars heq_ind_npars wf cparsubst0 idxsubst0 iparsubst0 isdecl declc. *) rewrite /argctxu. simpl. rewrite !map_map_compose. apply All_map_eq. @@ -2039,9 +2039,9 @@ Proof. relativize (context_assumptions _). erewrite <- expand_lets_app => //. now rewrite !lengths. - + * rewrite lift_mkApps /= !subst_mkApps /=. constructor. 2:constructor. - rewrite !map_app. + rewrite !map_app. rewrite -{3}(firstn_skipn (ind_npars mdecl) args) -brctxlen -brctxass. rewrite - !expand_lets_eq_map. rewrite -/(expand_lets_k (bcontext br) 0 _). @@ -2051,13 +2051,13 @@ Proof. 2:apply to_extended_list_case_branch_context. rewrite /prebrctx. eapply conv_context_rel_to_extended_list. - apply ws_cumul_ctx_pb_rel_app. symmetry. tea. + apply ws_cumul_ctx_pb_rel_app. symmetry. tea. now eapply Forall2_All2 in wfbr. } rewrite -map_expand_lets_to_extended_list. rewrite !map_map_compose. rewrite [map (fun x => _) (to_extended_list _)](@map_subst_let_expand_to_extended_list _ Σ _ Γ); tea. relativize (map _ _). - 2:{ eapply map_ext => x. rewrite -/(subst_let_expand _ _ _). + 2:{ eapply map_ext => x. rewrite -/(subst_let_expand _ _ _). now rewrite subst_let_expand_lift_id //; len. } rewrite map_id. transitivity (mkApps (tConstruct ci c (puinst p)) args). @@ -2074,7 +2074,7 @@ Proof. constructor. eapply R_global_instance_sym; tc. rewrite eqargs. now eapply (R_global_instance_cstr_irrelevant declc). - + - (* Case congruence: on a cofix, impossible *) eapply inversion_mkApps in typec as [? [tcof ?]] => //. eapply type_tCoFix_inv in tcof as [d [[[Hnth wfcofix] ?] ?]] => //. @@ -2087,8 +2087,8 @@ Proof. rewrite isdecl.p1 in t. apply ReflectEq.eqb_eq in t. rewrite t /= in heq_isCoFinite. discriminate. - - - (* Case congruence on a parameter *) + + - (* Case congruence on a parameter *) eassert (ctx_inst _ _ _ _) as Hctxi by (eapply ctx_inst_impl with (2 := X5); now intros ? []). eassert (PCUICEnvTyping.ctx_inst _ _ _ _ _) as X6. { eapply ctx_inst_impl with (2 := X5). intros ? ? ? ? [? r]; exact r. } @@ -2110,8 +2110,8 @@ Proof. eapply OnOne2_app_r in X3. unshelve eapply (ctx_inst_merge' _ _ _ _ _ X6 X5); tea. } pose proof X5 as X5'. - unshelve epose proof (ctx_inst_spine_subst _ X5); tea. - eapply spine_subst_smash in X4; tea. + unshelve epose proof (ctx_inst_spine_subst _ X5); tea. + eapply spine_subst_smash in X4; tea. eapply ctx_inst_length in X5. len in X5. rewrite context_assumptions_rev in X5. len in X5. pose proof (wf_predicate_length_pars H0). simpl in H. @@ -2123,7 +2123,7 @@ Proof. rewrite List.rev_app_distr in sppars spargs. rewrite skipn_app - !lenidx !skipn_all /= Nat.sub_diag skipn_0 in sppars spargs. rewrite firstn_app firstn_all Nat.sub_diag /= app_nil_r in spargs. - rewrite subst_instance_app List.rev_app_distr in X6. + rewrite subst_instance_app List.rev_app_distr in X6. have lenpars' := (OnOne2_length X3). unshelve epose proof (ctx_inst_spine_subst _ ctxi');tea. pose proof (spine_codom_wf _ _ _ _ _ X4);tea. @@ -2162,7 +2162,7 @@ Proof. 2:eapply All2_rev => //. clear cv. rewrite -app_context_assoc. eapply is_closed_context_weaken. fvs. - rewrite -on_free_vars_ctx_on_ctx_free_vars -closedP_shiftnP_eq + rewrite -on_free_vars_ctx_on_ctx_free_vars -closedP_shiftnP_eq -closed_ctx_on_ctx_free_vars. rewrite closedn_ctx_app !lengths. apply/andP; split. 2:cbn -[ind_predicate_context]. @@ -2203,7 +2203,7 @@ Proof. { eapply closed_context_conversion; tea. } do 2 forward X9 by auto. eapply type_ws_cumul_pb; tea. - { econstructor; tea. all: econstructor; tea. + { econstructor; tea. all: econstructor; tea. (* The branches contexts also depend on the parameters. *) apply All2i_nth_hyp in X9. eapply All2i_All2i_mix in X8; tea. clear X9. @@ -2219,7 +2219,7 @@ Proof. split => //. have declc : declared_constructor Σ (ci, cstr) mdecl idecl cdecl. { split => //. } - have convbctx : Σ ⊢ Γ,,, case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl = + have convbctx : Σ ⊢ Γ,,, case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl = Γ,,, case_branch_context ci mdecl (set_pparams p params') (forget_types (bcontext br)) cdecl. { rewrite /case_branch_context /case_branch_context_gen. eapply ws_cumul_ctx_pb_rel_app. @@ -2230,7 +2230,7 @@ Proof. 2:{ eapply All2_rev. eapply OnOne2_prod_inv in X3 as [redp _]. now eapply red_terms_ws_cumul_pb_terms. } - apply ws_cumul_ctx_pb_rel_app. + apply ws_cumul_ctx_pb_rel_app. eapply ws_cumul_ctx_pb_refl, wf_local_closed_context. rewrite /=. rewrite /cstr_branch_context. rewrite subst_instance_expand_lets_ctx. @@ -2243,12 +2243,12 @@ Proof. eapply wf_local_closed_context. eapply wf_local_smash_end. apply weaken_wf_local => //. eapply on_minductive_wf_params; tea. eapply isdecl. } - eapply (type_ws_cumul_pb (pb:=Conv)); tea. + eapply (type_ws_cumul_pb (pb:=Conv)); tea. + eapply closed_context_conversion; tea. + exists ps. exact wfcbcty'. + eapply ws_cumul_pb_mkApps; tea. { rewrite /ptm. cbn [preturn set_pparams]. - rewrite !lift_it_mkLambda_or_LetIn. + rewrite !lift_it_mkLambda_or_LetIn. eapply ws_cumul_pb_it_mkLambda_or_LetIn. relativize #|cstr_args cdecl|. eapply weakening_ws_cumul_ctx_pb; tea. @@ -2256,7 +2256,7 @@ Proof. now apply (case_branch_context_length_args wfbr). rewrite !case_predicate_context_length // /= Nat.add_0_r. relativize #|pcontext p|. relativize #|cstr_args cdecl|. - eapply weakening_ws_cumul_pb; tea. + eapply weakening_ws_cumul_pb; tea. apply isType_ws_cumul_pb_refl. now exists ps. now apply wf_local_closed_context. now apply case_branch_context_length_args. @@ -2282,7 +2282,7 @@ Proof. move: wfbrctx. move/wf_local_expand_lets. cbn. rewrite subst_instance_expand_lets_ctx map2_set_binder_name_expand_lets ?lengths //. - apply (wf_branch_length wfbr). + apply (wf_branch_length wfbr). rewrite subst_instance_subst_context instantiate_inds //. eapply declc. } rewrite 2!forallb_map. @@ -2322,7 +2322,7 @@ Proof. now eapply wt_cumul_pb_refl. - (* Case congruence on the return clause context *) - clear IHHu. destruct X0, X4 as []. + clear IHHu. destruct X0, X4 as []. eassert (ctx_inst _ _ _ _) as Hctxi by (eapply ctx_inst_impl with (2 := X5); now intros ? []). eassert (PCUICEnvTyping.ctx_inst _ _ _ _ _) as X6. { eapply ctx_inst_impl with (2 := X5). intros ? ? ? ? [? r]; exact r. } @@ -2332,17 +2332,17 @@ Proof. { eapply validity. econstructor; eauto. econstructor; eauto. split; eauto. apply (All2i_impl X8). intuition auto. } - assert (closed_red1 Σ (Γ,,, case_predicate_context ci mdecl idecl p) + assert (closed_red1 Σ (Γ,,, case_predicate_context ci mdecl idecl p) (preturn p) preturn'). { eapply closed_red1_eq_context_upto_names; tea. rewrite PCUICCasesContexts.inst_case_predicate_context_eq => //. reflexivity. } eapply type_ws_cumul_pb; tea. - * eapply type_Case; eauto. constructor; eauto. constructor; eauto. + * eapply type_Case; eauto. constructor; eauto. constructor; eauto. epose proof (wf_case_branches_types' (p:=set_preturn p preturn') ps _ brs isdecl (validity typec) H0 (forall_u _ X3) H4 X1). eapply All2i_All2_mix_left in X8. 2:exact (Forall2_All2 _ _ H4). clear H4. - eapply (All2i_All2i_mix X4) in X8. clear X4. + eapply (All2i_All2i_mix X4) in X8. clear X4. eapply (All2i_impl X8); intuition auto; clear X8. rewrite !case_branch_type_fst in a3 a4 *. set (cbty' := case_branch_type _ _ _ _ _ _ _ _) in *. @@ -2368,9 +2368,9 @@ Proof. eapply ws_cumul_pb_it_mkLambda_or_LetIn; tea. now eapply ws_cumul_ctx_pb_refl, wf_local_closed_context. cbn [preturn set_preturn]. - symmetry; apply closed_red1_ws_cumul_pb => //. - - - (* Case congruence on discriminee *) + symmetry; apply closed_red1_ws_cumul_pb => //. + + - (* Case congruence on discriminee *) destruct X0, X4. eassert (ctx_inst _ _ _ _) as Hctxi by (eapply ctx_inst_impl with (2 := X5); now intros ? []). eassert (PCUICEnvTyping.ctx_inst _ _ _ _ _) as X6. @@ -2399,7 +2399,7 @@ Proof. now rewrite clc'. + eapply isType_open in X0. rewrite on_free_vars_mkApps in X0. now move/andP: X0 => []. - + - (* Case congruence on branches *) destruct X0, X4. eassert (ctx_inst _ _ _ _) as Hctxi by (eapply ctx_inst_impl with (2 := X5); now intros ? []). @@ -2428,7 +2428,7 @@ Proof. 2:reflexivity. etransitivity. 2:eapply pre_case_branch_context_eq; cbn; tea. apply inst_case_branch_context_eq => //. apply isdecl. - + - (* Proj CoFix reduction *) assert(typecofix : Σ ;;; Γ |- tProj p (mkApps (tCoFix mfix idx) args0) : subst0 (mkApps (tCoFix mfix idx) args0 :: List.rev args) (subst_instance u pdecl.(proj_type))). @@ -2476,12 +2476,12 @@ Proof. rewrite -commut_lift_subst_rec // -(commut_lift_subst_rec _ _ 1 p.(proj_arg)) //. rewrite !simpl_subst_k //. specialize (projsubs _ _ _ typec). - + eapply (closed_red_red_subst0 (Γ := Γ) (Δ := skipn (context_assumptions (cstr_args cdecl) - p.(proj_arg)) (subst_context (List.rev args) 0 - (subst_context (extended_subst (ind_params mdecl)@[u] 0) 0 (smash_context [] - (subst_context (inds (inductive_mind p.(proj_ind)) u (ind_bodies mdecl)) + (subst_context (extended_subst (ind_params mdecl)@[u] 0) 0 (smash_context [] + (subst_context (inds (inductive_mind p.(proj_ind)) u (ind_bodies mdecl)) #|ind_params mdecl| (subst_instance u (cstr_args cdecl)))))))); auto. ** eapply wf_local_closed_context. eapply wf_local_app_skipn. @@ -2492,7 +2492,7 @@ Proof. eapply closed_red1_red. split. fvs. cbn. rewrite on_free_vars_mkApps. apply/andP; split; fvs. - eapply red_cofix_proj. + eapply red_cofix_proj. unfold unfold_cofix. rewrite Hnth. reflexivity. ** rewrite -subst_projs_inst. @@ -2510,7 +2510,7 @@ Proof. rewrite !subst_instance_app_ctx -app_context_assoc. move/(isType_subst_arities isdecl cu). rewrite subst_context_app. - rewrite closed_k_ctx_subst //. + rewrite closed_k_ctx_subst //. eapply (declared_inductive_closed_params_inst isdecl). move/isType_subst_extended_subst. move/(isType_weaken wfΓ); rewrite app_context_assoc. @@ -2530,7 +2530,7 @@ Proof. rewrite (subst_instance_id_mdecl _ _ _ cu) //. rewrite subst_instance_extended_subst //. - - (* Proj Constructor reduction *) + - (* Proj Constructor reduction *) pose proof (validity typec). simpl in typec. pose proof typec as typec'. @@ -2589,7 +2589,7 @@ Proof. clear sp. eapply nth_error_Some_length in H. rewrite List.skipn_length in H. lia. } destruct sp as [decl [Hnth Hu0]]. - simpl in on_projs. red in on_projs. len in Hnth. + simpl in on_projs. red in on_projs. len in Hnth. eapply (type_ws_cumul_pb (pb:=Cumul)); eauto. { rewrite firstn_skipn. eapply (isType_subst_instance_decl _ _ _ _ _ u wf isdecl.p1.p1.p1) in projty; eauto. @@ -2598,7 +2598,7 @@ Proof. eapply (weaken_ctx Γ) in Hs; auto. rewrite (subst_app_simpl [_]). destruct projeq as [decl' [hnthargs hty wf' projeq1 projty']]. - eapply (substitution0 (T := tSort _)). + eapply (substitution0 (T := tSort _)). eapply (PCUICSubstitution.substitution (Γ' := subst_instance u (smash_context [] (ind_params mdecl))) (Δ := [vass _ _]) (T := tSort _)); eauto. rewrite firstn_all2 in iparsubst0. lia. @@ -2615,7 +2615,7 @@ Proof. rewrite firstn_skipn. rewrite smash_context_app smash_context_acc in on_projs. rewrite nth_error_app_lt in on_projs. - { autorewrite with len. simpl. + { autorewrite with len. simpl. eapply nth_error_Some_length in Hnth. autorewrite with len in Hnth. now simpl in Hnth. } rewrite nth_error_subst_context in on_projs. @@ -2666,12 +2666,12 @@ Proof. assert(#|firstn parg (skipn (ind_npars mdecl) args0)| = parg) as hnarg. { rewrite firstn_length_le // skipn_length; lia. } rewrite hnarg in hs. rewrite <- hs. clear hs. rewrite subst_app_decomp. - epose proof (subst_app_simpl + epose proof (subst_app_simpl (map (subst0 [mkApps (tConstruct pind 0 u0) (map (lift0 (ind_npars mdecl)) args0)]) (projs pind (ind_npars mdecl) parg))) as hs. rewrite !lengths in hs. rewrite -{}hs subst_app_decomp !lengths (distr_subst (List.rev args)) !lengths. - assert (map (subst0 (List.rev args)) (subst_instance u (extended_subst (ind_params mdecl) 0)) = + assert (map (subst0 (List.rev args)) (subst_instance u (extended_subst (ind_params mdecl) 0)) = iparsubst) as ->. { rewrite firstn_all2 in iparsubst0. lia. rewrite subst_instance_extended_subst. @@ -2684,10 +2684,10 @@ Proof. rewrite /pargctxu /argctxu /argsu !smash_context_subst_empty -(subst_instance_smash _ _ []). rewrite !nth_error_subst_context nth_error_map Hdecl. simpl => [= Hdecl']. subst decl'. simpl in cum. - len in cum; simpl in cum. + len in cum; simpl in cum. assert(context_assumptions (cstr_args cdecl) - S (context_assumptions (cstr_args cdecl) - S parg) = parg) by lia. - rewrite H5 in cum. + rewrite H5 in cum. set (idx := S (context_assumptions (cstr_args cdecl) - S parg)) in *. assert (wfpargctxu1 : wf_local Σ (Γ ,,, skipn idx (smash_context [] pargctxu1))). { simpl. apply wf_local_app_skipn. apply wf_local_smash_end; auto. @@ -2697,13 +2697,13 @@ Proof. depelim cumdecls. cbn in *. rename eqt into cum. eapply (substitution_ws_cumul_pb (Γ' := skipn idx (smash_context [] pargctxu1)) (Γ'' := []) (s := skipn idx (List.rev (skipn (ind_npars mdecl) args0)))) in cum. - 2:{ eapply spine_subst_smash in idxsubst0; eauto. + 2:{ eapply spine_subst_smash in idxsubst0; eauto. eapply subslet_skipn, idxsubst0. } assert (skipn idx (List.rev (skipn (ind_npars mdecl) args0)) = (List.rev (firstn parg (skipn (ind_npars mdecl) args0)))) as eq. { rewrite /idx skipn_rev. lia_f_equal. rewrite skipn_length; lia. } assert (parg = #|List.rev (firstn parg (skipn (ind_npars mdecl) args0))|) as hnarg'. { rewrite !lengths firstn_length_le ?skipn_length; lia. } - rewrite eq in cum. + rewrite eq in cum. rewrite subst_context_nil in cum. simpl in cum. rewrite -(subst_app_simpl' _ _ 0) in cum => //. rewrite subst_app_decomp in cum. @@ -2716,12 +2716,12 @@ Proof. eapply (substitution_ws_cumul_pb (Γ'' := [])); eauto. eapply iparsubst0. simpl. rewrite (distr_subst_rec _ _ _ #|ind_params mdecl| 0); len => /=. - rewrite /indsubst1 subst_instance_inds. + rewrite /indsubst1 subst_instance_inds. rewrite (subst_instance_id_mdecl Σ u mdecl) //. rewrite (subst_closedn (List.rev args)). - { eapply (closedn_subst _ 0). + { eapply (closedn_subst _ 0). eapply declared_minductive_closed_inds; eauto. exact isdecl. - simpl; len. + simpl; len. rewrite closedn_subst_instance. clear projsubsl. eapply closed_wf_local in wfdecl. @@ -2742,7 +2742,7 @@ Proof. eapply (substitution_ws_cumul_pb_subst_conv (Γ := _ ,,, _) (Δ := [])); auto. { rewrite -(subst_instance_length u). eapply subslet_lift; eauto. rewrite -eq. - eapply spine_subst_smash in idxsubst0; eauto. + eapply spine_subst_smash in idxsubst0; eauto. eapply subslet_skipn. eapply idxsubst0. } { specialize (projsubsl (Γ ,,, subst_instance u (ind_params mdecl))). rewrite -projs_inst_lift. @@ -2762,7 +2762,7 @@ Proof. eapply closed_red1_red. eapply wt_closed_red1. { eapply nth_error_Some_length in H3. - have: parg - S n < #|ind_projs idecl| by lia. + have: parg - S n < #|ind_projs idecl| by lia. move/nth_error_Some' => [pdecl' hnth]. eexists. econstructor; tea. split; [eapply isdecl|]. cbn. split => //. tea. len. } constructor. @@ -2796,7 +2796,7 @@ Proof. move=> i'. rewrite /shiftnP !orb_false_r. move/Nat.ltb_lt => lt. apply/Nat.ltb_lt. lia. } - - (* Proj congruence: discriminee reduction *) + - (* Proj congruence: discriminee reduction *) eapply type_ws_cumul_pb; [econstructor|..]; eauto. eapply validity; eauto. instantiate (1:= tProj p c). @@ -2804,12 +2804,12 @@ Proof. eapply ws_cumul_pb_eq_le. rewrite (subst_app_simpl [c']) (subst_app_simpl [c]). set(bann := {| binder_name := nAnon; binder_relevance := idecl.(ind_relevance) |}). - eapply (untyped_substitution_ws_cumul_pb_subst_conv (Γ := Γ) + eapply (untyped_substitution_ws_cumul_pb_subst_conv (Γ := Γ) (Γ' := []) (Δ := [vass bann (mkApps (tInd p.(proj_ind) u) args)]) (Δ' := [vass bann (mkApps (tInd p.(proj_ind) u) args)])); auto. 4-5:repeat constructor. * symmetry. apply red_terms_ws_cumul_pb_terms; constructor; auto. - now apply closed_red1_red. + now apply closed_red1_red. * rewrite on_free_vars_ctx_app andb_true_r on_free_vars_ctx_app H /=. cbn. rewrite shiftnP_add /=. move/validity/isType_open: typec => -> //. @@ -2830,11 +2830,11 @@ Proof. - (* Fix congruence *) apply mkApps_Fix_spec in H5. simpl in H5. subst args. simpl. destruct narg; discriminate. - + - (* Fix congruence: type reduction *) assert(fixl :#|fix_context mfix| = #|fix_context mfix1|) by now (rewrite !fix_context_length; apply (OnOne2_length X2)). assert(convctx : conv_context cumulAlgo_gen Σ (Γ ,,, fix_context mfix) (Γ ,,, fix_context mfix1)). - { clear -wf wfΓ X X2 H2 fixl. + { clear -wf wfΓ X X2 H2 fixl. eapply All2_fold_app => //. apply conv_ctx_refl. clear X. eapply All2_fold_impl. @@ -2846,7 +2846,7 @@ Proof. now apply closed_red1_ws_cumul_pb. rewrite H. reflexivity. * cbn in H2. move/andP: H2 => [_ Htl]. eapply forallb_All in Htl. eapply All_All2; tea. - move=> [dname dty dbod] /= h. rewrite /test_def /=; + move=> [dname dty dbod] /= h. rewrite /test_def /=; move/andP=> [hty _]. split; try reflexivity. eapply ws_cumul_pb_refl => //. * move/andP: H2 => [/andP [Hty _] _]. @@ -2885,12 +2885,12 @@ Proof. red. simple apply infer_typing_sort_impl with id HT; move=> /= [Hs IH]. specialize (IH _ red). eapply (weakening _ _ _ _ (tSort _)); auto. - apply All_mfix_wf; auto. + apply All_mfix_wf; auto. apply red_cumul, red1_red. eapply (weakening_red1 _ []); auto. 2:eapply red. pose proof (Hs := HT.π2.1). - eapply subject_closed in Hs. + eapply subject_closed in Hs. eapply (closedn_on_free_vars (P:=xpredT)) in Hs. now eapply on_free_vars_any_xpredT. @@ -2938,7 +2938,7 @@ Proof. rewrite convctx. apply conv_ctx_refl. + move=> [na ty b rarg] [na' ty' b' rarg'] /= [[red eq] HT] [Hb IH']. noconf eq. - now rewrite -convctx. + now rewrite -convctx. * eapply wf_fixpoint_red1_body; eauto. eapply OnOne2_impl; tea; cbn; intuition auto. apply a2. apply a2. @@ -2949,7 +2949,7 @@ Proof. - (* CoFix congruence: type reduction *) assert(fixl :#|fix_context mfix| = #|fix_context mfix1|) by now (rewrite !fix_context_length; apply (OnOne2_length X2)). assert(convctx : conv_context cumulAlgo_gen Σ (Γ ,,, fix_context mfix) (Γ ,,, fix_context mfix1)). - { clear -wf wfΓ X X2 H2 fixl. + { clear -wf wfΓ X X2 H2 fixl. eapply All2_fold_app => //; trea. clear X. eapply All2_fold_impl. eapply (conv_decls_fix_context (Γ := Γ)) => //. @@ -2960,7 +2960,7 @@ Proof. now apply closed_red1_ws_cumul_pb. rewrite H. reflexivity. * cbn in H2. move/andP: H2 => [_ Htl]. eapply forallb_All in Htl. eapply All_All2; tea. - move=> [dname dty dbod] /= h. rewrite /test_def /=; + move=> [dname dty dbod] /= h. rewrite /test_def /=; move/andP=> [hty _]. split; try reflexivity. eapply ws_cumul_pb_refl => //. * move/andP: H2 => [/andP [Hty _] _]. @@ -2999,12 +2999,12 @@ Proof. red. simple apply infer_typing_sort_impl with id HT; move=> /= [Hs IH]. specialize (IH _ red). eapply (weakening _ _ _ _ (tSort _)); auto. - apply All_mfix_wf; auto. + apply All_mfix_wf; auto. apply red_cumul, red1_red. eapply (weakening_red1 _ []); auto. 2:eapply red. pose proof (Hs := HT.π2.1). - eapply subject_closed in Hs. + eapply subject_closed in Hs. eapply (closedn_on_free_vars (P:=xpredT)) in Hs. now eapply on_free_vars_any_xpredT. @@ -3052,7 +3052,7 @@ Proof. rewrite convctx. apply conv_ctx_refl. + move=> [na ty b rarg] [na' ty' b' rarg'] /= [[red eq] HT] [Hb IH']. noconf eq. - now rewrite -convctx. + now rewrite -convctx. * eapply wf_cofixpoint_red1_body; eauto. eapply OnOne2_impl; tea; cbn; intuition auto. apply a2. apply a2. @@ -3069,8 +3069,8 @@ Definition sr_stmt {cf:checker_flags} (Σ : global_env_ext) Γ t T := forall u, red Σ Γ t u -> Σ ;;; Γ |- u : T. Lemma typing_closed_red1 {cf:checker_flags} {Σ : global_env_ext} {Γ t u T} {wfΣ : wf Σ} : - Σ ;;; Γ |- t : T -> - red1 Σ Γ t u -> + Σ ;;; Γ |- t : T -> + red1 Σ Γ t u -> Σ ;;; Γ ⊢ t ⇝1 u. Proof. intros Ht hr. split; auto. @@ -3079,8 +3079,8 @@ Proof. Qed. Lemma typing_closed_red {cf:checker_flags} {Σ : global_env_ext} {Γ t u T} {wfΣ : wf Σ} : - Σ ;;; Γ |- t : T -> - red Σ Γ t u -> + Σ ;;; Γ |- t : T -> + red Σ Γ t u -> Σ ;;; Γ ⊢ t ⇝ u. Proof. intros Ht hr. split; auto. @@ -3095,7 +3095,7 @@ Proof. now eapply typing_closed_red1. Defined. -Theorem subject_reduction {cf:checker_flags} : +Theorem subject_reduction {cf:checker_flags} : forall (Σ : global_env_ext) Γ t u T, wf Σ -> Σ ;;; Γ |- t : T -> red Σ Γ t u -> Σ ;;; Γ |- u : T. Proof. intros * wfΣ Hty Hred. @@ -3104,23 +3104,23 @@ Proof. now eapply typing_closed_red1. Qed. -Corollary subject_reduction1_closed {cf:checker_flags} : - forall (Σ : global_env_ext) Γ t u T, wf Σ -> +Corollary subject_reduction1_closed {cf:checker_flags} : + forall (Σ : global_env_ext) Γ t u T, wf Σ -> Σ ;;; Γ |- t : T -> Σ ;;; Γ ⊢ t ⇝1 u -> Σ ;;; Γ |- u : T. Proof. intros * wfΣ Hty Hred. now eapply (env_prop_typing sr_red1). Qed. -Corollary subject_reduction_closed {cf:checker_flags} : - forall (Σ : global_env_ext) Γ t u T, wf Σ -> +Corollary subject_reduction_closed {cf:checker_flags} : + forall (Σ : global_env_ext) Γ t u T, wf Σ -> Σ ;;; Γ |- t : T -> Σ ;;; Γ ⊢ t ⇝ u -> Σ ;;; Γ |- u : T. Proof. intros * wfΣ Hty Hred. eapply subject_reduction; tea. apply Hred. Qed. -Lemma type_reduction {cf} {Σ} {wfΣ : wf Σ} {Γ t A B} : +Lemma type_reduction {cf} {Σ} {wfΣ : wf Σ} {Γ t A B} : Σ ;;; Γ |- t : A -> red Σ Γ A B -> Σ ;;; Γ |- t : B. Proof. intros Ht Hr. @@ -3130,7 +3130,7 @@ Proof. eapply conv_cumul. now apply PCUICCumulativity.red_conv. Defined. -Lemma type_reduction_closed {cf} {Σ} {wfΣ : wf Σ} {Γ t A B} : +Lemma type_reduction_closed {cf} {Σ} {wfΣ : wf Σ} {Γ t A B} : Σ ;;; Γ |- t : A -> Σ ;;; Γ ⊢ A ⇝ B -> Σ ;;; Γ |- t : B. Proof. intros Ht Hr. eapply type_reduction; tea. exact Hr. @@ -3203,7 +3203,7 @@ Section SRContext. apply conv_ctx_refl. destruct s as [[red ->]|[red ->]]. constructor; pcuics. - now apply PCUICCumulativity.red_conv, red1_red. + now apply PCUICCumulativity.red_conv, red1_red. constructor. pcuic. now apply PCUICCumulativity.red_conv, red1_red. reflexivity. - constructor; auto. reflexivity. } @@ -3238,7 +3238,7 @@ Section SRContext. red; eapply context_conversion; eauto. - eapply context_conversion; eauto. Qed. - + Lemma wf_local_red1 {Σ} {wfΣ : wf Σ} {Γ Γ'} : red1_ctx Σ Γ Γ' -> wf_local Σ Γ -> wf_local Σ Γ'. Proof using Type. @@ -3289,7 +3289,7 @@ Section SRContext. intros h. red in h. apply red_ctx_clos_rt_red1_ctx in h. induction h; eauto using wf_local_red1. Qed. - + Lemma eq_context_upto_names_upto_names Γ Δ : eq_context_upto_names Γ Δ -> Γ ≡Γ Δ. Proof using Type. @@ -3297,7 +3297,7 @@ Section SRContext. depelim r; constructor; subst; auto. all:cbnr; eauto. Qed. - + Lemma wf_local_subst1 {Σ} {wfΣ : wf Σ} Γ na b t Γ' : wf_local Σ (Γ ,,, [],, vdef na b t ,,, Γ') -> wf_local Σ (Γ ,,, subst_context [b] 0 Γ'). diff --git a/pcuic/theories/PCUICSafeLemmata.v b/pcuic/theories/PCUICSafeLemmata.v index bf439d604..973780d23 100644 --- a/pcuic/theories/PCUICSafeLemmata.v +++ b/pcuic/theories/PCUICSafeLemmata.v @@ -6,10 +6,10 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICGlobalEnv PCUICNamelessDef PCUICAlpha PCUICNormal PCUICInversion PCUICReduction PCUICSubstitution PCUICConversion PCUICContextConversion PCUICContextConversionTyp PCUICValidity - PCUICArities PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICGeneration + PCUICArities PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICGeneration PCUICUnivSubstitutionConv PCUICUnivSubstitutionTyp PCUICParallelReductionConfluence PCUICWellScopedCumulativity - PCUICOnFreeVars PCUICSpine PCUICInductives + PCUICOnFreeVars PCUICSpine PCUICInductives PCUICWeakeningConv PCUICWeakeningTyp PCUICContexts PCUICInductiveInversion. Require Import ssreflect ssrbool. @@ -1066,7 +1066,7 @@ Section Lemmata. Qed. End Lemmata. -Lemma welltyped_brs {cf} (Σ : global_env_ext) (HΣ :∥ wf_ext Σ ∥) Γ ci p t2 brs T : Σ ;;; Γ |- tCase ci p t2 brs : T -> +Lemma welltyped_brs {cf} (Σ : global_env_ext) (HΣ :∥ wf_ext Σ ∥) Γ ci p t2 brs T : Σ ;;; Γ |- tCase ci p t2 brs : T -> ∥ All (fun br => welltyped Σ (Γ ,,, inst_case_branch_context p br) (bbody br)) brs ∥. Proof. intros Ht. destruct HΣ. constructor. diff --git a/pcuic/theories/PCUICSigmaCalculus.v b/pcuic/theories/PCUICSigmaCalculus.v index b32443626..67f9214e0 100644 --- a/pcuic/theories/PCUICSigmaCalculus.v +++ b/pcuic/theories/PCUICSigmaCalculus.v @@ -69,7 +69,7 @@ Section map_predicate_shift. Lemma map_shift_puinst (p : predicate term) : finst (puinst p) = puinst (map_predicate_shift p). Proof using Type. reflexivity. Qed. - + End map_predicate_shift. Section map_branch_shift. @@ -85,7 +85,7 @@ Section map_branch_shift. Lemma map_shift_bbody (b : branch term) : fn (shift #|b.(bcontext)| f) (bbody b) = bbody (map_branch_shift b). Proof using Type. reflexivity. Qed. - + Lemma map_shift_bcontext (b : branch term) : (bcontext b) = bcontext (map_branch_shift b). Proof using Type. reflexivity. Qed. @@ -93,7 +93,7 @@ End map_branch_shift. Notation map_branches_shift ren f := (map (map_branch_shift ren shiftn f)). - + Fixpoint rename f t : term := match t with | tRel i => tRel (f i) @@ -153,7 +153,7 @@ Proof. Qed. #[global] Hint Resolve map_predicate_shift_eq_spec : all. -Lemma map_branch_shift_eq_spec {T T'} (fn : (nat -> T) -> term -> term) +Lemma map_branch_shift_eq_spec {T T'} (fn : (nat -> T) -> term -> term) (fn' : (nat -> T') -> term -> term) shift shift' (f : nat -> T) (g : nat -> T') (x : branch term) : fn (shift #|x.(bcontext)| f) (bbody x) = fn' (shift' #|x.(bcontext)| g) (bbody x) -> @@ -203,7 +203,7 @@ Proof. intros f f' Hff' t t' ->. now apply rename_ext. Qed. Instance rename_proper_pointwise : Proper (`=1` ==> pointwise_relation _ Logic.eq) rename. Proof. intros f f' Hff' t. now apply rename_ext. Qed. -Lemma map_predicate_shift_proper {T} (fn : (nat -> T) -> term -> term) shift : +Lemma map_predicate_shift_proper {T} (fn : (nat -> T) -> term -> term) shift : Proper (`=1` ==> `=1`) fn -> Proper (Logic.eq ==> `=1` ==> `=1`) shift -> Proper (`=1` ==> `=1` ==> `=1`) (map_predicate_shift fn shift). @@ -222,7 +222,7 @@ Proof. now intros x. Qed. -Lemma map_branch_shift_proper {T} (fn : (nat -> T) -> term -> term) shift : +Lemma map_branch_shift_proper {T} (fn : (nat -> T) -> term -> term) shift : Proper (`=1` ==> `=1`) fn -> Proper (Logic.eq ==> `=1` ==> `=1`) shift -> Proper (`=1` ==> `=1`) (map_branch_shift fn shift). @@ -263,7 +263,7 @@ Proof. - destruct (Nat.ltb_spec i (n + m)); try lia. - destruct (Nat.ltb_spec i (n + m)); try lia; destruct (Nat.ltb_spec (i - n) m); try lia. - rewrite Nat.add_assoc. f_equal. f_equal. lia. + rewrite Nat.add_assoc. f_equal. f_equal. lia. Qed. #[global] @@ -333,7 +333,7 @@ Proof. red in X. solve_all. rewrite b. now rewrite shiftn_lift_renaming. - f_equal; auto. - red in X. solve_all. + red in X. solve_all. rewrite b. now rewrite shiftn_lift_renaming. Qed. #[global] @@ -361,8 +361,8 @@ Proof. * assert (n + f' (x - n) - n = f' (x - n)) as ->; lia. Qed. -(* Lemma map_branches_shiftn (fn : (nat -> nat) -> term -> term) f f' l : - map_branches_shift fn f (map_branches_shift fn f' l) = +(* Lemma map_branches_shiftn (fn : (nat -> nat) -> term -> term) f f' l : + map_branches_shift fn f (map_branches_shift fn f' l) = List.map (fun i => map_branch (fn (shiftn #|bcontext i| f) ∘ (fn (shiftn #|bcontext i| f'))) i) l. Proof. rewrite map_map_compose. apply map_ext => i. @@ -383,7 +383,7 @@ Hint Rewrite mapi_context_compose : map. Lemma rename_compose f f' : rename f ∘ rename f' =1 rename (f ∘ f'). Proof. intros x. - induction x in f, f' |- * using term_forall_list_ind; simpl; + induction x in f, f' |- * using term_forall_list_ind; simpl; f_equal; auto; solve_all; try match goal with @@ -393,7 +393,7 @@ Proof. - rewrite /map_predicate_shift /= map_map. solve_all; len. rewrite e. f_equal; solve_all. - * apply rename_ext, shiftn_compose. + * apply rename_ext, shiftn_compose. - rewrite /map_branch_shift /=. f_equal; solve_all. * len. rewrite b. apply rename_ext, shiftn_compose. Qed. @@ -427,7 +427,7 @@ Lemma map_predicate_shift_map_predicate {shift : nat -> (nat -> T) -> nat -> T} {finst finst' f'} {f : nat -> T} - {p : predicate term} + {p : predicate term} (compose : (nat -> T) -> (term -> term) -> (nat -> T)) : Proper (`=1` ==> `=1`) fn -> @@ -452,7 +452,7 @@ Lemma map_predicate_shift_map_predicate_gen {shift' : nat -> (nat -> T') -> nat -> T'} {finst finst' f'} {f : nat -> T} - {p : predicate term} + {p : predicate term} (compose : (nat -> T) -> (term -> term) -> (nat -> T')) : Proper (`=1` ==> `=1`) fn -> @@ -475,7 +475,7 @@ Lemma map_predicate_map_predicate_shift {shift : nat -> (nat -> T) -> nat -> T} {finst finst' f'} {f : nat -> T} - {p : predicate term} + {p : predicate term} (compose : (term -> term) -> (nat -> T) -> (nat -> T)) : Proper (`=1` ==> `=1`) fn -> @@ -503,7 +503,7 @@ Qed. #[global] Hint Rewrite rename_predicate_rename_predicate : map. -Lemma map_branch_shift_map_branch_shift {T} +Lemma map_branch_shift_map_branch_shift {T} {fn : (nat -> T) -> term -> term} {shift : nat -> (nat -> T) -> nat -> T} {f f' : nat -> T} {b : branch term} @@ -661,7 +661,7 @@ Instance ren_ext : Morphisms.Proper (`=1` ==> `=1`)%signature ren. Proof. reduce_goal. unfold ren. now rewrite H. Qed. - + Lemma ren_shiftn n f : up n (ren f) =1 ren (shiftn n f). Proof. unfold ren, up, shiftn. @@ -1280,8 +1280,8 @@ Lemma nat_recursion_ext {A} (x : A) f g n : Nat.recursion x f n = Nat.recursion x g n. Proof. intros. - generalize (Nat.le_refl n). - induction n at 1 3 4; simpl; auto. + generalize (Nat.le_refl n). + induction n at 1 3 4; simpl; auto. intros. simpl. rewrite IHn0; try lia. now rewrite H. Qed. @@ -1311,7 +1311,7 @@ Proof. -- assert (Hr:i < #|ren_ids m |) by (rewrite ren_ids_length; lia). assert (Hi:i < #|idsn m |) by (rewrite idsn_length; lia). rewrite (subst_consn_lt Hi) subst_ids_lt //. - rewrite subst_consn_compose. + rewrite subst_consn_compose. rewrite (subst_consn_lt); len => //. rewrite -rename_inst rename_idsn_idsn subst_ids_lt //. Qed. @@ -1471,7 +1471,7 @@ Proof. rewrite subst_consn_tip. unfold Up. apply subst_consn_proper; auto. rewrite shiftk_shift_l. intros i'. unfold subst_cons, subst_compose. - destruct i' => //; auto; simpl. + destruct i' => //; auto; simpl. - unfold shiftk. now rewrite Nat.add_0_r. - simpl. now rewrite inst_assoc. Qed. @@ -1515,7 +1515,7 @@ Proof. * solve_all. unfold map_branch_k, map_branch_shift; destruct x; cbn in *; f_equal; solve_all. + now rewrite /shiftf up_up. - - f_equal; eauto; solve_all; auto. + - f_equal; eauto; solve_all; auto. rewrite b. apply inst_ext. intros t'; now rewrite (up_up #|m| k). - f_equal; eauto. solve_all; auto. @@ -1568,7 +1568,7 @@ Fixpoint subst_app (t : term) (us : list term) : term := Lemma subst_consn_shiftn n (l : list term) σ : #|l| = n -> ↑^n ∘s (l ⋅n σ) =1 σ. Proof. induction n in l |- *; simpl; intros; sigma. - - destruct l; try discriminate. now sigma. + - destruct l; try discriminate. now sigma. - destruct l; try discriminate. simpl in *. rewrite subst_consn_subst_cons. simpl; sigma. apply IHn. lia. @@ -1639,7 +1639,7 @@ Proof. Qed. Lemma up_ext_closed k' k s s' : - (forall i, i < k' -> s i = s' i) -> + (forall i, i < k' -> s i = s' i) -> forall i, i < k + k' -> up k s i = up k s' i. Proof. @@ -1647,13 +1647,13 @@ Proof. intros. f_equal. apply Hs. lia. Qed. -Lemma subst_consn_eq s0 s1 s2 s3 x : +Lemma subst_consn_eq s0 s1 s2 s3 x : x < #|s0| -> #|s0| = #|s2| -> subst_fn s0 x = subst_fn s2 x -> (s0 ⋅n s1) x = (s2 ⋅n s3) x. Proof. unfold subst_fn; intros Hx Heq Heqx. - unfold subst_consn. + unfold subst_consn. destruct (nth_error s0 x) eqn:Heq'; destruct (nth_error s2 x) eqn:Heq''; auto; (apply nth_error_None in Heq''|| apply nth_error_None in Heq'); lia. @@ -1700,7 +1700,7 @@ Proof. red in X. eapply All_map_eq. eapply (All_impl X). intros x [IH IH']. - apply map_def_eq_spec. + apply map_def_eq_spec. * apply IH. * specialize (IH' (#|m| + k)). sigma. @@ -1710,7 +1710,7 @@ Proof. red in X. eapply All_map_eq. eapply (All_impl X). intros x [IH IH']. - apply map_def_eq_spec. + apply map_def_eq_spec. * apply IH. * specialize (IH' (#|m| + k)). sigma. now rewrite - !up_Upn up_up !up_Upn. @@ -1775,7 +1775,7 @@ Proof. rewrite /subst_compose; sigma. unfold shift. simpl. now rewrite /subst_compose /=. Qed. -(* +(* Lemma subst_consn_compose_r l σ' σ : σ ∘s (l ⋅n σ') =1 map (inst (σ ∘s (subst_fn l))) l ⋅n (σ ∘s σ'). Proof. induction l; simpl. @@ -1812,7 +1812,7 @@ Proof. * f_equal. now rewrite !Nat.add_succ_r !subst_reli_lift_id //. Qed. -Lemma expand_lets_k_vass Γ na ty k t : +Lemma expand_lets_k_vass Γ na ty k t : expand_lets_k (Γ ++ [{| decl_name := na; decl_body := None; decl_type := ty |}]) k t = expand_lets_k Γ k t. Proof. @@ -1826,14 +1826,14 @@ Proof. move: (context_assumptions_length_bound Γ); lia. Qed. -Lemma expand_lets_vass Γ na ty t : +Lemma expand_lets_vass Γ na ty t : expand_lets (Γ ++ [{| decl_name := na; decl_body := None; decl_type := ty |}]) t = expand_lets Γ t. Proof. rewrite /expand_lets; apply expand_lets_k_vass. Qed. -Lemma expand_lets_k_vdef Γ na b ty k t : +Lemma expand_lets_k_vdef Γ na b ty k t : expand_lets_k (Γ ++ [{| decl_name := na; decl_body := Some b; decl_type := ty |}]) k t = expand_lets_k (subst_context [b] 0 Γ) k (subst [b] (k + #|Γ|) t). Proof. @@ -1848,7 +1848,7 @@ Proof. reflexivity. Qed. -Lemma expand_lets_vdef Γ na b ty t : +Lemma expand_lets_vdef Γ na b ty t : expand_lets (Γ ++ [{| decl_name := na; decl_body := Some b; decl_type := ty |}]) t = expand_lets (subst_context [b] 0 Γ) (subst [b] #|Γ| t). Proof. @@ -1859,13 +1859,13 @@ Definition expand_lets_k_ctx_vass Γ k Δ na ty : expand_lets_k_ctx Γ k (Δ ++ [{| decl_name := na; decl_body := None; decl_type := ty |}]) = expand_lets_k_ctx Γ (S k) Δ ++ [{| decl_name := na; decl_body := None; decl_type := expand_lets_k Γ k ty |}]. -Proof. +Proof. now rewrite /expand_lets_k_ctx lift_context_app subst_context_app /=; simpl. Qed. Definition expand_lets_k_ctx_decl Γ k Δ d : expand_lets_k_ctx Γ k (Δ ++ [d]) = expand_lets_k_ctx Γ (S k) Δ ++ [map_decl (expand_lets_k Γ k) d]. -Proof. +Proof. rewrite /expand_lets_k_ctx lift_context_app subst_context_app /=; simpl. unfold app_context. simpl. rewrite /subst_context /fold_context_k /=. @@ -1875,8 +1875,8 @@ Qed. Lemma expand_lets_nil t : expand_lets [] t = t. Proof. by rewrite /expand_lets /expand_lets_k /= subst_empty lift0_id. Qed. -Lemma expand_lets_it_mkProd_or_LetIn Γ Δ k t : - expand_lets_k Γ k (it_mkProd_or_LetIn Δ t) = +Lemma expand_lets_it_mkProd_or_LetIn Γ Δ k t : + expand_lets_k Γ k (it_mkProd_or_LetIn Δ t) = it_mkProd_or_LetIn (expand_lets_k_ctx Γ k Δ) (expand_lets_k Γ (k + #|Δ|) t). Proof. revert k; induction Δ as [|[na [b|] ty] Δ] using ctx_length_rev_ind; simpl; auto; intros k. @@ -1893,31 +1893,31 @@ Proof. now rewrite -(H Δ ltac:(lia) (S k)). Qed. -Lemma expand_lets_k_mkApps Γ k f args : +Lemma expand_lets_k_mkApps Γ k f args : expand_lets_k Γ k (mkApps f args) = mkApps (expand_lets_k Γ k f) (map (expand_lets_k Γ k) args). Proof. now rewrite /expand_lets_k lift_mkApps subst_mkApps map_map_compose. Qed. -Lemma expand_lets_mkApps Γ f args : +Lemma expand_lets_mkApps Γ f args : expand_lets Γ (mkApps f args) = mkApps (expand_lets Γ f) (map (expand_lets Γ) args). Proof. now rewrite /expand_lets expand_lets_k_mkApps. Qed. -Lemma expand_lets_tRel k Γ : +Lemma expand_lets_tRel k Γ : expand_lets Γ (tRel (k + #|Γ|)) = tRel (k + context_assumptions Γ). Proof. - rewrite /expand_lets /expand_lets_k. + rewrite /expand_lets /expand_lets_k. rewrite lift_rel_ge; try lia. rewrite subst_rel_gt; len; try lia. lia_f_equal. Qed. Lemma context_assumptions_context {Γ} : - assumption_context Γ -> + assumption_context Γ -> context_assumptions Γ = #|Γ|. Proof. induction 1; simpl; auto. @@ -1932,23 +1932,23 @@ Proof. - depelim H. now eapply IHΓ. Qed. -Lemma expand_lets_assumption_context Γ t : +Lemma expand_lets_assumption_context Γ t : assumption_context Γ -> expand_lets Γ t = t. Proof. induction Γ using rev_ind. - rewrite /expand_lets /expand_lets_k /=. intros _. rewrite lift0_id subst_empty //. - - intros ass. eapply assumption_context_app in ass as [assl assx]. + - intros ass. eapply assumption_context_app in ass as [assl assx]. depelim assx. rewrite /expand_lets /expand_lets_k; len; simpl. - rewrite extended_subst_app /=. + rewrite extended_subst_app /=. rewrite subst_app_simpl /=; len. rewrite subst_context_lift_id // lift0_context. rewrite (context_assumptions_context assl). simpl. rewrite !Nat.add_1_r subst_reli_lift_id //. rewrite /expand_lets_ctx /expand_lets_k_ctx in IHΓ. - specialize (IHΓ assl). + specialize (IHΓ assl). rewrite /expand_lets /expand_lets_k in IHΓ. now rewrite (context_assumptions_context assl) in IHΓ. Qed. @@ -1961,7 +1961,7 @@ Proof. - intros ass. eapply assumption_context_app in ass as [assl assx]. depelim assx. rewrite /expand_lets_ctx /expand_lets_k_ctx; len; simpl. - rewrite extended_subst_app /=. + rewrite extended_subst_app /=. rewrite subst_app_context /=; len. rewrite subst_context_lift_id // lift0_context. rewrite (context_assumptions_context assl). simpl. @@ -1971,7 +1971,7 @@ Proof. now simpl in IHΓ. Qed. -Lemma subst_extended_subst s Γ k : extended_subst (subst_context s k Γ) 0 = +Lemma subst_extended_subst s Γ k : extended_subst (subst_context s k Γ) 0 = map (subst s (k + context_assumptions Γ)) (extended_subst Γ 0). Proof. induction Γ as [|[na [b|] ty] Γ]; simpl; auto; rewrite subst_context_snoc /=; @@ -1980,13 +1980,13 @@ Proof. rewrite commut_lift_subst_rec; try lia. rewrite distr_subst. now len. - elim: Nat.leb_spec => //. lia. - - rewrite ? (lift_extended_subst _ 1); rewrite IHΓ. + - rewrite ? (lift_extended_subst _ 1); rewrite IHΓ. rewrite !map_map_compose. apply map_ext. - intros x. + intros x. erewrite (commut_lift_subst_rec); lia_f_equal. Qed. -Lemma expand_lets_subst_comm Γ s : +Lemma expand_lets_subst_comm Γ s : expand_lets (subst_context s 0 Γ) ∘ subst s #|Γ| =1 subst s (context_assumptions Γ) ∘ expand_lets Γ. Proof. unfold expand_lets, expand_lets_k; simpl; intros x. len. @@ -1996,14 +1996,14 @@ Proof. Qed. Lemma map_expand_lets_subst_comm Γ s : - map (expand_lets (subst_context s 0 Γ)) ∘ (map (subst s #|Γ|)) =1 + map (expand_lets (subst_context s 0 Γ)) ∘ (map (subst s #|Γ|)) =1 map (subst s (context_assumptions Γ)) ∘ (map (expand_lets Γ)). Proof. intros l. rewrite !map_map_compose. apply map_ext. intros x; apply expand_lets_subst_comm. Qed. -Lemma map_subst_expand_lets s Γ : +Lemma map_subst_expand_lets s Γ : context_assumptions Γ = #|s| -> subst0 (map (subst0 s) (extended_subst Γ 0)) =1 subst0 s ∘ expand_lets Γ. Proof. @@ -2013,7 +2013,7 @@ Proof. simpl. rewrite simpl_subst_k //. Qed. -Lemma map_subst_expand_lets_k s Γ k x : +Lemma map_subst_expand_lets_k s Γ k x : context_assumptions Γ = #|s| -> subst (map (subst0 s) (extended_subst Γ 0)) k x = (subst s k ∘ expand_lets_k Γ k) x. Proof. @@ -2024,7 +2024,7 @@ Proof. simpl. rewrite simpl_subst_k //. Qed. -Lemma subst_context_map_subst_expand_lets s Γ Δ : +Lemma subst_context_map_subst_expand_lets s Γ Δ : context_assumptions Γ = #|s| -> subst_context (map (subst0 s) (extended_subst Γ 0)) 0 Δ = subst_context s 0 (expand_lets_ctx Γ Δ). Proof. @@ -2039,7 +2039,7 @@ Proof. rewrite map_subst_expand_lets_k //. Qed. -Lemma subst_context_map_subst_expand_lets_k s Γ Δ k : +Lemma subst_context_map_subst_expand_lets_k s Γ Δ k : context_assumptions Γ = #|s| -> subst_context (map (subst0 s) (extended_subst Γ 0)) k Δ = subst_context s k (expand_lets_k_ctx Γ k Δ). Proof. @@ -2171,16 +2171,16 @@ Lemma shift_subst_consn_ge (n : nat) (l : list term) (σ : nat -> term) : Proof. intros Hlt i. rewrite /subst_compose /shiftk /=. - rewrite subst_consn_ge; try lia. lia_f_equal. + rewrite subst_consn_ge; try lia. lia_f_equal. Qed. -Lemma skipn_subst n s σ : +Lemma skipn_subst n s σ : n <= #|s| -> skipn n s ⋅n σ =1 ↑^(n) ∘s (s ⋅n σ). Proof. intros hn i. rewrite /subst_consn /shiftk /subst_compose /=. - rewrite nth_error_skipn. + rewrite nth_error_skipn. destruct nth_error => //. rewrite List.skipn_length. lia_f_equal. Qed. diff --git a/pcuic/theories/PCUICSpine.v b/pcuic/theories/PCUICSpine.v index 66b1a8f73..07ba52a7f 100644 --- a/pcuic/theories/PCUICSpine.v +++ b/pcuic/theories/PCUICSpine.v @@ -2,7 +2,7 @@ From Coq Require Import Utf8 CRelationClasses ProofIrrelevance. From MetaCoq.Template Require Import config Universes utils BasicAst. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICInduction - PCUICReflect PCUICLiftSubst PCUICSigmaCalculus + PCUICReflect PCUICLiftSubst PCUICSigmaCalculus PCUICUnivSubst PCUICTyping PCUICUnivSubstitutionConv PCUICUnivSubstitutionTyp PCUICCumulativity PCUICPosition PCUICEquality PCUICInversion PCUICCumulativity PCUICReduction @@ -39,9 +39,9 @@ Lemma typing_spine_eq {cf:checker_flags} Σ Γ ty s s' ty' : typing_spine Σ Γ ty s' ty'. Proof. now intros ->. Qed. -Lemma All2_fold_mapi_right P (Γ Δ : context) g : +Lemma All2_fold_mapi_right P (Γ Δ : context) g : All2_fold (fun Γ Δ d d' => - P Γ (mapi_context g Δ) d (map_decl (g #|Γ|) d')) Γ Δ + P Γ (mapi_context g Δ) d (map_decl (g #|Γ|) d')) Γ Δ -> All2_fold P Γ (mapi_context g Δ). Proof. induction 1; simpl; constructor; intuition auto; @@ -65,7 +65,7 @@ Qed. Lemma subslet_eq_context_alpha {cf} {Σ Γ s Δ Δ'} : eq_context_upto_names Δ Δ' → - subslet Σ Γ s Δ → + subslet Σ Γ s Δ → subslet Σ Γ s Δ'. Proof. intros eq subs. @@ -74,7 +74,7 @@ Proof. * depelim c; subst; constructor; auto. Qed. -Lemma eq_context_alpha_conv {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} : +Lemma eq_context_alpha_conv {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} : eq_context_upto_names Γ Γ' -> conv_context cumulAlgo_gen Σ Γ Γ'. Proof. intros a. @@ -84,7 +84,7 @@ Proof. intros ?? []; constructor; subst; auto; reflexivity. Qed. -Lemma wf_local_alpha {cf} {Σ} {wfΣ : wf Σ} Γ Γ' : eq_context_upto_names Γ Γ' -> +Lemma wf_local_alpha {cf} {Σ} {wfΣ : wf Σ} Γ Γ' : eq_context_upto_names Γ Γ' -> wf_local Σ Γ -> wf_local Σ Γ'. Proof. @@ -97,12 +97,12 @@ Qed. Lemma subslet_eq_context_alpha_dom {cf} {Σ} {wfΣ : wf Σ} {Γ Γ' s Δ} : eq_context_upto_names Γ Γ' → - subslet Σ Γ s Δ → + subslet Σ Γ s Δ → subslet Σ Γ' s Δ. Proof. intros eq subs. induction subs in Γ', eq |- *; try constructor. - * now apply IHsubs. + * now apply IHsubs. * eapply context_conversion; tea. eapply wf_local_alpha; tea. eapply typing_wf_local in t0. exact t0. now eapply eq_context_alpha_conv. @@ -113,7 +113,7 @@ Proof. Qed. -Lemma subslet_app {cf:checker_flags} Σ Γ s s' Δ Δ' : +Lemma subslet_app {cf:checker_flags} Σ Γ s s' Δ Δ' : subslet Σ Γ s (subst_context s' 0 Δ) -> subslet Σ Γ s' Δ' -> subslet Σ Γ (s ++ s') (Δ' ,,, Δ). @@ -134,7 +134,7 @@ induction Δ in s, s', Δ' |- *; simpl; auto; move=> sub'. simpl; constructor; eauto. Qed. -Lemma subslet_skipn {cf:checker_flags} Σ Γ s Δ n : +Lemma subslet_skipn {cf:checker_flags} Σ Γ s Δ n : subslet Σ Γ s Δ -> subslet Σ Γ (skipn n s) (skipn n Δ). Proof. @@ -146,7 +146,7 @@ Proof. * rewrite !skipn_S. auto. Qed. -Lemma untyped_subslet_skipn Γ s Δ n : +Lemma untyped_subslet_skipn Γ s Δ n : untyped_subslet Γ s Δ -> untyped_subslet Γ (skipn n s) (skipn n Δ). Proof. @@ -158,14 +158,14 @@ Proof. * rewrite !skipn_S. auto. Qed. -Lemma untyped_subslet_eq_subst Γ s s' Δ : +Lemma untyped_subslet_eq_subst Γ s s' Δ : untyped_subslet Γ s Δ -> s = s' -> untyped_subslet Γ s' Δ. Proof. now intros H ->. Qed. Lemma context_subst_app_inv {ctx ctx' : context} {args s : list term} : context_subst (subst_context (skipn #|ctx| s) 0 ctx) - (skipn (context_assumptions ctx') args) + (skipn (context_assumptions ctx') args) (firstn #|ctx| s) × context_subst ctx' (firstn (context_assumptions ctx') args) (skipn #|ctx| s) -> context_subst (ctx ++ ctx') args s. @@ -236,7 +236,7 @@ Arguments inst_subslet {cf Σ Γ inst s Δ}. #[global] Hint Resolve inst_ctx_subst inst_subslet : pcuic. -Lemma spine_subst_eq {cf:checker_flags} {Σ Γ inst s Δ Δ'} : +Lemma spine_subst_eq {cf:checker_flags} {Σ Γ inst s Δ Δ'} : spine_subst Σ Γ inst s Δ -> Δ = Δ' -> spine_subst Σ Γ inst s Δ'. @@ -250,10 +250,10 @@ Lemma spine_subst_inj_subst {cf:checker_flags} {Σ Γ inst s s' Δ} : s = s'. Proof. intros [_ _ c _] [_ _ c' _]. - induction c in s', c' |- *; depelim c'; simpl; auto. + induction c in s', c' |- *; depelim c'; simpl; auto. apply app_inj_tail in H as [-> ->]. f_equal; eauto. - specialize (IHc _ c'). now subst. + specialize (IHc _ c'). now subst. Qed. Lemma make_context_subst_skipn {Γ args s s'} : @@ -274,16 +274,16 @@ Proof. now eapply skipn_n_Sn. Qed. -Inductive arity_spine {cf : checker_flags} (Σ : global_env_ext) (Γ : context) : +Inductive arity_spine {cf : checker_flags} (Σ : global_env_ext) (Γ : context) : term -> list term -> term -> Type := | arity_spine_nil ty : arity_spine Σ Γ ty [] ty | arity_spine_conv ty ty' : isType Σ Γ ty' -> - Σ ;;; Γ ⊢ ty ≤ ty' -> arity_spine Σ Γ ty [] ty' -| arity_spine_def : forall (tl : list term) - (na : aname) (A a B B' : term), + Σ ;;; Γ ⊢ ty ≤ ty' -> arity_spine Σ Γ ty [] ty' +| arity_spine_def : forall (tl : list term) + (na : aname) (A a B B' : term), arity_spine Σ Γ (B {0 := a}) tl B' -> arity_spine Σ Γ (tLetIn na a A B) tl B' -| arity_spine_ass : forall (hd : term) (tl : list term) +| arity_spine_ass : forall (hd : term) (tl : list term) (na : aname) (A B B' : term), Σ;;; Γ |- hd : A -> arity_spine Σ Γ (B {0 := hd}) tl B' -> @@ -305,7 +305,7 @@ Proof. induction Γ in inst, s' |- *. + intros HΔ Hi. depelim Hi. now rewrite app_nil_r. -+ intros H' Hsub. ++ intros H' Hsub. rewrite subst_context_snoc0 in Hsub. destruct a as [na [b|] ty]; depelim Hsub. @@ -325,9 +325,9 @@ Qed. Section WfEnv. Context {cf} {Σ : global_env_ext} {wfΣ : wf Σ}. - Lemma typing_spine_strengthen {Γ T args U} : + Lemma typing_spine_strengthen {Γ T args U} : typing_spine Σ Γ T args U -> - forall T', + forall T', isType Σ Γ T' -> Σ ;;; Γ ⊢ T' ≤ T -> typing_spine Σ Γ T' args U. @@ -363,7 +363,7 @@ Section WfEnv. econstructor; eauto with pcuic. eapply isType_ws_cumul_pb_refl; eexists; eauto. econstructor. all:eauto with pcuic. - + eapply inversion_Prod in HA as (? & ? & ? & ? & ?); tea. eapply isType_subst. econstructor. econstructor. rewrite subst_empty; eauto. econstructor; cbn; eauto. @@ -373,17 +373,17 @@ Section WfEnv. exists (tProd na' A' B'). exists s. intuition; eauto. econstructor; eauto with wf. 1,2: eexists; eauto. 1:eapply isType_ws_cumul_pb_refl; eexists; eauto. - - + + eapply typing_spine_strengthen; tea. - + eapply inversion_Prod in HA as (? & ? & ? & ? & ?); tea. eapply isType_subst. econstructor. econstructor. rewrite subst_empty; eauto. econstructor; cbn; eauto. Unshelve. eauto. Qed. - Lemma subst_type_local_ctx {Γ Γ' Δ Δ' s ctxs} : + Lemma subst_type_local_ctx {Γ Γ' Δ Δ' s ctxs} : wf_local Σ (Γ ,,, Δ ,,, Γ') -> type_local_ctx (lift_typing typing) Σ (Γ ,,, Δ ,,, Γ') Δ' ctxs -> subslet Σ Γ s Δ -> @@ -400,11 +400,11 @@ Section WfEnv. all: rewrite -app_context_assoc in Hs. all: eapply substitution in Hs; eauto. all: rewrite subst_context_app app_context_assoc in Hs. - all: simpl in Hs; rewrite Nat.add_0_r in Hs. + all: simpl in Hs; rewrite Nat.add_0_r in Hs. all: now rewrite app_context_length in Hs. Qed. - Lemma subst_sorts_local_ctx {Γ Γ' Δ Δ' s ctxs} : + Lemma subst_sorts_local_ctx {Γ Γ' Δ Δ' s ctxs} : wf_local Σ (Γ ,,, Δ ,,, Γ') -> sorts_local_ctx (lift_typing typing) Σ (Γ ,,, Δ ,,, Γ') Δ' ctxs -> subslet Σ Γ s Δ -> @@ -418,7 +418,7 @@ Section WfEnv. rewrite -app_context_assoc in Hs. eapply substitution in Hs; eauto. rewrite subst_context_app app_context_assoc in Hs. - simpl in Hs. rewrite Nat.add_0_r in Hs. + simpl in Hs. rewrite Nat.add_0_r in Hs. now rewrite app_context_length in Hs. + rewrite -app_context_assoc in b1. eapply substitution in b1; eauto. @@ -429,7 +429,7 @@ Section WfEnv. rewrite -app_context_assoc in b. eapply substitution in b; eauto. rewrite subst_context_app app_context_assoc in b. - rewrite Nat.add_0_r in b. + rewrite Nat.add_0_r in b. now rewrite app_context_length in b. Qed. @@ -441,7 +441,7 @@ Section WfEnv. have wfΓ := isType_wf_local wf. induction sp; try constructor; auto; pcuic. - eapply typing_spine_strengthen; eauto. - 2:{ eapply into_ws_cumul_pb. + 2:{ eapply into_ws_cumul_pb. apply red_cumul. apply red1_red. constructor. 1-2:eauto with fvs. eapply isType_tLetIn_red in wf; eauto with fvs. } @@ -452,7 +452,7 @@ Section WfEnv. Import PCUICConversion. - Lemma arity_typing_spine {Γ Γ' s inst s'} : + Lemma arity_typing_spine {Γ Γ' s inst s'} : typing_spine Σ Γ (it_mkProd_or_LetIn Γ' (tSort s)) inst (tSort s') -> [× (#|inst| = context_assumptions Γ'), leq_universe (global_ext_constraints Σ) s s' & ∑ instsubst, spine_subst Σ Γ inst instsubst Γ']. @@ -460,7 +460,7 @@ Section WfEnv. revert s inst s'. (* assert (wf_local Σ Γ). now apply wf_local_app_l in wfΓ'. move X after wfΓ'. rename X into wfΓ. *) - generalize (le_n #|Γ'|). + generalize (le_n #|Γ'|). generalize (#|Γ'|) at 2. induction n in Γ' |- *. - destruct Γ' using rev_ind; try clear IHΓ'; simpl; intros len s inst s' Hsp. @@ -490,7 +490,7 @@ Section WfEnv. eapply isType_it_mkProd_or_LetIn_wf_local in Hsp. specialize (IHn (subst_context [b] 0 l)). forward IHn by rewrite subst_context_length; lia. - specialize (IHn s inst s' Hsp'). + specialize (IHn s inst s' Hsp'). rewrite context_assumptions_subst in IHn. destruct IHn as [instlen leq [instsubst [wfdom wfcodom cs subi]]]. split => //. @@ -517,7 +517,7 @@ Section WfEnv. rewrite /subst1 subst_it_mkProd_or_LetIn /= in cumulB. specialize (IHn (subst_context [hd0] 0 l)). forward IHn by rewrite subst_context_length; lia. - specialize (IHn s tl0 s'). 2:pcuic. + specialize (IHn s tl0 s'). 2:pcuic. rewrite context_assumptions_subst in IHn. assert (Σ ;;; Γ |- hd0 : ty). { eapply type_ws_cumul_pb; tea. @@ -545,8 +545,8 @@ Section WfEnv. * apply subslet_app => //. now apply subslet_ass_tip. Qed. -(*Lemma typing_spine_it_mkProd_or_LetIn_gen {Γ Δ : context} {T args s s' args' T'} : - make_context_subst (List.rev Δ) args s' = Some s -> +(*Lemma typing_spine_it_mkProd_or_LetIn_gen {Γ Δ : context} {T args s s' args' T'} : + make_context_subst (List.rev Δ) args s' = Some s -> typing_spine Σ Γ (subst0 s T) args' T' -> #|args| = context_assumptions Δ -> subslet Σ Γ s Δ -> @@ -572,16 +572,16 @@ Proof. rewrite /subst1. now rewrite -subst_app_simpl. * rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=. - rewrite rev_app_distr in Hsub. + rewrite rev_app_distr in Hsub. simpl in Hsub. destruct args; try discriminate. simpl in Hargs. rewrite Nat.add_1_r in Hargs. noconf Hargs. - intros subs. rewrite app_context_assoc in subs. + intros subs. rewrite app_context_assoc in subs. specialize (IHn Δ _ T args s _ ltac:(lia) Hsub Hsp H subs). intros Har. forward IHn. now rewrite it_mkProd_or_LetIn_app. eapply subslet_app_inv in subs as [subsl subsr]. depelim subsl. - have Hskip := make_context_subst_skipn Hsub. + have Hskip := make_context_subst_skipn Hsub. rewrite List.rev_length in Hskip. rewrite Hskip in H0; noconf H0. simpl; eapply typing_spine_prod; auto; first now rewrite /subst1 -subst_app_simpl. @@ -589,8 +589,8 @@ Proof. Qed.*) - Lemma typing_spine_it_mkProd_or_LetIn_gen {Γ Δ Δ' : context} {T args s s' args' T'} : - make_context_subst (List.rev Δ) args s' = Some s -> + Lemma typing_spine_it_mkProd_or_LetIn_gen {Γ Δ Δ' : context} {T args s s' args' T'} : + make_context_subst (List.rev Δ) args s' = Some s -> typing_spine Σ Γ (subst0 s T) args' T' -> #|args| = context_assumptions Δ -> subslet Σ Γ s (Δ' ,,, Δ) -> @@ -624,15 +624,15 @@ Qed.*) rewrite /subst1. now rewrite -subst_app_simpl. * rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=. - rewrite rev_app_distr in Hsub. + rewrite rev_app_distr in Hsub. simpl in Hsub. destruct args; try discriminate. simpl in Hargs. rewrite Nat.add_1_r in Hargs. noconf Hargs. - intros subs. rewrite app_context_assoc in subs. + intros subs. rewrite app_context_assoc in subs. specialize (IHn l _ T args s _ ltac:(lia) Hsub Hsp H subs). intros Har. eapply subslet_app_inv in subs as [subsl subsr]. depelim subsl. - have Hskip := make_context_subst_skipn Hsub. + have Hskip := make_context_subst_skipn Hsub. rewrite List.rev_length in Hskip. rewrite Hskip in H0; noconf H0. forward IHn. { eapply isType_apply in Har; tea. @@ -641,20 +641,20 @@ Qed.*) now rewrite /subst1 -subst_app_simpl. Qed. - Lemma typing_spine_it_mkProd_or_LetIn {Γ Δ T args s args' T'} : - make_context_subst (List.rev Δ) args [] = Some s -> + Lemma typing_spine_it_mkProd_or_LetIn {Γ Δ T args s args' T'} : + make_context_subst (List.rev Δ) args [] = Some s -> typing_spine Σ Γ (subst0 s T) args' T' -> #|args| = context_assumptions Δ -> subslet Σ Γ s Δ -> isType Σ Γ (it_mkProd_or_LetIn Δ T) -> typing_spine Σ Γ (it_mkProd_or_LetIn Δ T) (args ++ args') T'. Proof using wfΣ. - intros. + intros. pose proof (@typing_spine_it_mkProd_or_LetIn_gen Γ Δ [] T args s [] args' T'); auto. now rewrite subst_empty app_context_nil_l in X2. Qed. - Lemma typing_spine_it_mkProd_or_LetIn' {Γ Δ T args s args' T'} : + Lemma typing_spine_it_mkProd_or_LetIn' {Γ Δ T args s args' T'} : spine_subst Σ Γ args s Δ -> typing_spine Σ Γ (subst0 s T) args' T' -> isType Σ Γ (it_mkProd_or_LetIn Δ T) -> @@ -666,14 +666,14 @@ Qed.*) now pose proof (context_subst_length2 inst_ctx_subst0). Qed. - Lemma typing_spine_it_mkProd_or_LetIn_close_make_subst {Γ Δ T args s} : - make_context_subst (List.rev Δ) args [] = Some s -> + Lemma typing_spine_it_mkProd_or_LetIn_close_make_subst {Γ Δ T args s} : + make_context_subst (List.rev Δ) args [] = Some s -> #|args| = context_assumptions Δ -> subslet Σ Γ s Δ -> isType Σ Γ (it_mkProd_or_LetIn Δ T) -> typing_spine Σ Γ (it_mkProd_or_LetIn Δ T) args (subst0 s T). Proof using wfΣ. - intros. + intros. pose proof (@typing_spine_it_mkProd_or_LetIn_gen Γ Δ [] T args s [] []); auto. rewrite app_nil_r subst_empty in X1. apply X1; eauto. eapply isType_substitution_it_mkProd_or_LetIn in X0; tea. @@ -681,7 +681,7 @@ Qed.*) now rewrite app_context_nil_l. Qed. - Lemma typing_spine_it_mkProd_or_LetIn_close {Γ Δ T args s T'} : + Lemma typing_spine_it_mkProd_or_LetIn_close {Γ Δ T args s T'} : spine_subst Σ Γ args s Δ -> isType Σ Γ (it_mkProd_or_LetIn Δ T) -> T' = (subst0 s T) -> @@ -692,13 +692,13 @@ Qed.*) eapply make_context_subst_spec_inv. now rewrite List.rev_involutive. now eapply context_subst_length2 in inst_ctx_subst0. - Qed. + Qed. Lemma spine_subst_conv {Γ inst insts Δ inst' insts' Δ'} : spine_subst Σ Γ inst insts Δ -> spine_subst Σ Γ inst' insts' Δ' -> ws_cumul_ctx_pb_rel Conv Σ Γ Δ Δ' -> - ws_cumul_pb_terms Σ Γ inst inst' -> + ws_cumul_pb_terms Σ Γ inst inst' -> ws_cumul_pb_terms Σ Γ insts insts'. Proof using wfΣ. move=> [_ wf cs sl] [_ wf' cs' sl'] [clΓ cv]. @@ -716,10 +716,10 @@ Qed.*) eapply (substitution_ws_cumul_pb_subst_conv (Δ := [])); eauto using subslet_untyped_subslet with fvs. Qed. - Lemma spine_subst_subst {Γ Γ0 Γ' i s Δ sub} : + Lemma spine_subst_subst {Γ Γ0 Γ' i s Δ sub} : spine_subst Σ (Γ ,,, Γ0 ,,, Γ') i s Δ -> subslet Σ Γ sub Γ0 -> - spine_subst Σ (Γ ,,, subst_context sub 0 Γ') + spine_subst Σ (Γ ,,, subst_context sub 0 Γ') (map (subst sub #|Γ'|) i) (map (subst sub #|Γ'|) s) (subst_context sub #|Γ'| Δ). Proof using wfΣ. @@ -735,7 +735,7 @@ Qed.*) specialize (IHcs _ _ Γ' subs). epose proof (context_subst_def _ _ _ na (subst sub (#|Γ1| + #|Γ'|) b) (subst sub (#|Γ1| + #|Γ'|) t) IHcs). rewrite /subst_decl /map_decl /=. - rewrite distr_subst. + rewrite distr_subst. now rewrite (context_subst_length cs) in X |- *. clear cs wfΔ. induction subl; rewrite ?subst_context_snoc ?map_app; simpl; try constructor; auto. @@ -749,7 +749,7 @@ Qed.*) now rewrite - !distr_subst in X. Qed. - Lemma spine_subst_subst_first {Γ Γ' i s Δ sub} : + Lemma spine_subst_subst_first {Γ Γ' i s Δ sub} : spine_subst Σ (Γ ,,, Γ') i s Δ -> subslet Σ [] sub Γ -> spine_subst Σ (subst_context sub 0 Γ') (map (subst sub #|Γ'|) i) (map (subst sub #|Γ'|) s) @@ -770,7 +770,7 @@ Qed.*) + eapply (weaken_ctx Γ); eauto. Qed. - Lemma spine_subst_weaken {Γ i s Δ Γ'} : + Lemma spine_subst_weaken {Γ i s Δ Γ'} : wf_local Σ Γ' -> spine_subst Σ Γ i s Δ -> spine_subst Σ (Γ' ,,, Γ) i s Δ. @@ -803,7 +803,7 @@ Qed.*) Lemma spine_subst_smash_app_inv {Γ Δ Δ' δ δ'} : #|δ| = context_assumptions Δ -> spine_subst Σ Γ (δ ++ δ') (List.rev (δ ++ δ')) (smash_context [] (Δ ,,, Δ')) -> - spine_subst Σ Γ δ (List.rev δ) (smash_context [] Δ) × + spine_subst Σ Γ δ (List.rev δ) (smash_context [] Δ) × spine_subst Σ Γ δ' (List.rev δ') (subst_context_let_expand (List.rev δ) Δ (smash_context [] Δ')). Proof using wfΣ. @@ -822,7 +822,7 @@ Qed.*) assert (skipn (context_assumptions Δ') (List.rev (δ ++ δ')) = List.rev δ). { rewrite List.rev_app_distr. - erewrite (skipn_all_app_eq) => //; rewrite List.rev_length //. } + erewrite (skipn_all_app_eq) => //; rewrite List.rev_length //. } rewrite H H0 in spidx, sppars. split => //. Qed. @@ -857,7 +857,7 @@ Qed.*) eapply (typing_subst_instance'' Σ'); simpl; eauto. Qed. - Lemma spine_subst_weakening {Γ i s Δ Γ'} : + Lemma spine_subst_weakening {Γ i s Δ Γ'} : wf_local Σ (Γ ,,, Γ') -> spine_subst Σ Γ i s Δ -> spine_subst Σ (Γ ,,, Γ') (map (lift0 #|Γ'|) i) (map (lift0 #|Γ'|) s) (lift_context #|Γ'| 0 Δ). @@ -870,7 +870,7 @@ Qed.*) Qed. Lemma ctx_inst_length {Γ args Δ} : - ctx_inst Σ Γ args Δ -> + ctx_inst Σ Γ args Δ -> #|args| = context_assumptions Δ. Proof using Type. induction 1; simpl; auto. @@ -879,7 +879,7 @@ Qed.*) rewrite context_assumptions_mapi in IHX. congruence. Qed. - Lemma ctx_inst_subst {Γ Γ0 Γ' i Δ sub} : + Lemma ctx_inst_subst {Γ Γ0 Γ' i Δ sub} : ctx_inst Σ (Γ ,,, Γ0 ,,, Γ') i Δ -> subslet Σ Γ sub Γ0 -> ctx_inst Σ (Γ ,,, subst_context sub 0 Γ') (map (subst sub #|Γ'|) i) (subst_telescope sub #|Γ'| Δ). @@ -896,7 +896,7 @@ Qed.*) now rewrite (subst_telescope_comm [b]). Qed. - Lemma ctx_inst_weaken {Γ i Δ Γ'} : + Lemma ctx_inst_weaken {Γ i Δ Γ'} : wf_local Σ Γ' -> ctx_inst Σ Γ i Δ -> ctx_inst Σ (Γ' ,,, Γ) i Δ. @@ -906,7 +906,7 @@ Qed.*) now eapply (weaken_ctx Γ'). Qed. - Lemma make_context_subst_tele s s' Δ inst sub : + Lemma make_context_subst_tele s s' Δ inst sub : make_context_subst (subst_telescope s' #|s| Δ) inst s = Some sub -> make_context_subst Δ inst (s ++ s') = Some (sub ++ s'). Proof using Type. @@ -928,7 +928,7 @@ Qed.*) | ctx_inst_def na b t inst Δ c => ctx_inst_sub c ++ [b] end. - Lemma ctx_inst_sub_spec {Γ Δ args} (c : ctx_inst Σ Γ args Δ) : + Lemma ctx_inst_sub_spec {Γ Δ args} (c : ctx_inst Σ Γ args Δ) : make_context_subst Δ args [] = Some (ctx_inst_sub c). Proof using Type. induction c; simpl; auto. @@ -936,7 +936,7 @@ Qed.*) apply (make_context_subst_tele [] [b]) in IHc. now rewrite subst_empty. Qed. - + Lemma subst_telescope_empty k Δ : subst_telescope [] k Δ = Δ. Proof using Type. unfold subst_telescope, mapi. generalize 0. induction Δ; simpl; auto. @@ -946,26 +946,26 @@ Qed.*) f_equal. apply IHΔ. Qed. - Lemma subst_telescope_app s k Γ Δ : subst_telescope s k (Γ ++ Δ) = subst_telescope s k Γ ++ + Lemma subst_telescope_app s k Γ Δ : subst_telescope s k (Γ ++ Δ) = subst_telescope s k Γ ++ subst_telescope s (#|Γ| + k) Δ. Proof using Type. rewrite /subst_telescope /mapi. rewrite mapi_rec_app. f_equal. rewrite mapi_rec_add. apply mapi_rec_ext. intros. destruct x as [na [b|] ty]; simpl; f_equal; f_equal; lia. Qed. - + Hint Extern 0 => lia : lia. - Lemma context_assumptions_subst_telescope s k Δ : context_assumptions (subst_telescope s k Δ) = + Lemma context_assumptions_subst_telescope s k Δ : context_assumptions (subst_telescope s k Δ) = context_assumptions Δ. Proof using Type. - rewrite /subst_telescope /mapi. generalize 0. + rewrite /subst_telescope /mapi. generalize 0. induction Δ; simpl; auto. destruct a as [na [b|] ty]; simpl; auto with lia. intros. specialize (IHΔ (S n)). lia. Qed. - Lemma subst_app_telescope s s' k Γ : + Lemma subst_app_telescope s s' k Γ : subst_telescope (s ++ s') k Γ = subst_telescope s k (subst_telescope s' (#|s| + k) Γ). Proof using Type. rewrite /subst_telescope /mapi. @@ -993,7 +993,7 @@ Qed.*) now rewrite /subst_telescope mapi_length. Qed. - Lemma arity_spine_it_mkProd_or_LetIn {Γ Δ T args s args' T'} : + Lemma arity_spine_it_mkProd_or_LetIn {Γ Δ T args s args' T'} : spine_subst Σ Γ args s Δ -> arity_spine Σ Γ (subst0 s T) args' T' -> arity_spine Σ Γ (it_mkProd_or_LetIn Δ T) (args ++ args') T'. @@ -1011,7 +1011,7 @@ Qed.*) depelim subsl; depelim subsl. apply context_subst_app in cs as [cs cs']. simpl in *. rewrite skipn_0 in cs. - specialize (X (subst_context (skipn #|Γ0| s) 0 Γ0) ltac:(now autorewrite with len) _ _ + specialize (X (subst_context (skipn #|Γ0| s) 0 Γ0) ltac:(now autorewrite with len) _ _ (subst [b] #|Γ0| T) cs subsl'). rewrite subst_empty in H. rewrite H in X. apply X. @@ -1032,7 +1032,7 @@ Qed.*) constructor; auto. rewrite /subst1 subst_it_mkProd_or_LetIn. rewrite Nat.add_0_r. - specialize (X (subst_context (skipn #|Γ0| s) 0 Γ0) ltac:(now autorewrite with len) _ _ + specialize (X (subst_context (skipn #|Γ0| s) 0 Γ0) ltac:(now autorewrite with len) _ _ (subst [t1] #|Γ0| T) cs subsl'). rewrite -{1}H1. apply X. rewrite -subst_app_simpl'. @@ -1041,14 +1041,14 @@ Qed.*) rewrite -H1. now rewrite firstn_skipn. Qed. - Lemma spine_subst_is_closed_context Γ args inst ctx : + Lemma spine_subst_is_closed_context Γ args inst ctx : spine_subst Σ Γ args inst ctx -> is_closed_context Γ. Proof using wfΣ. now move=> [] /wf_local_closed_context. Qed. - Lemma spine_subst_is_closed_context_codom Γ args inst ctx : + Lemma spine_subst_is_closed_context_codom Γ args inst ctx : spine_subst Σ Γ args inst ctx -> is_closed_context (Γ ,,, ctx). Proof using wfΣ. @@ -1056,7 +1056,7 @@ Qed.*) Qed. Hint Resolve spine_subst_is_closed_context spine_subst_is_closed_context_codom : fvs. - Lemma arity_spine_it_mkProd_or_LetIn_Sort {Γ ctx s s' args inst} : + Lemma arity_spine_it_mkProd_or_LetIn_Sort {Γ ctx s s' args inst} : wf_universe Σ s' -> leq_universe Σ s s' -> spine_subst Σ Γ args inst ctx -> @@ -1077,7 +1077,7 @@ Qed.*) rewrite app_length IHc subst_telescope_length /=; lia. Qed. - Lemma ctx_inst_app {Γ} {Δ : context} {Δ' args args'} + Lemma ctx_inst_app {Γ} {Δ : context} {Δ' args args'} (dom : ctx_inst Σ Γ args Δ) : ctx_inst Σ Γ args' (subst_telescope (ctx_inst_sub dom) 0 Δ') -> ctx_inst Σ Γ (args ++ args') (Δ ++ Δ'). @@ -1094,10 +1094,10 @@ Qed.*) now rewrite subst_telescope_app Nat.add_0_r. Qed. - Lemma ctx_inst_app_inv {Γ} {Δ : context} {Δ' args} + Lemma ctx_inst_app_inv {Γ} {Δ : context} {Δ' args} (c : ctx_inst Σ Γ args (Δ ++ Δ')) : ∑ (dom : ctx_inst Σ Γ (firstn (context_assumptions Δ) args) Δ), - ctx_inst Σ Γ (skipn (context_assumptions Δ) args) (subst_telescope (ctx_inst_sub dom) 0 Δ'). + ctx_inst Σ Γ (skipn (context_assumptions Δ) args) (subst_telescope (ctx_inst_sub dom) 0 Δ'). Proof using Type. revert args Δ' c. induction Δ using ctx_length_ind; intros. @@ -1148,7 +1148,7 @@ Qed.*) rewrite app_nil_r; apply ctx_inst_sub_eq. now rewrite skipn_0. now rewrite subst_telescope_empty. simpl in *. destruct d as [na [b|] ty]; simpl in *. - depelim c; simpl in *. + depelim c; simpl in *. depelim x; simpl in *. injection H0. discriminate. injection H0. discriminate. specialize (H (subst_telescope [b] 0 Γ0) ltac:(now rewrite /subst_telescope mapi_length)). @@ -1168,7 +1168,7 @@ Qed.*) revert c. rewrite subst_telescope_app. intros c. specialize (H _ _ c). simpl in *. revert H. rewrite context_assumptions_subst_telescope. - intros. + intros. specialize (H x). revert c0. rewrite subst_app_telescope. rewrite (ctx_inst_subst_length x) subst_telescope_length. @@ -1188,14 +1188,14 @@ Qed.*) depelim c; simpl in c. depelim c; simpl in *. constructor; simpl in *; auto. Qed. - Lemma ctx_inst_ass {Γ args na t} (c : ctx_inst Σ Γ args [vass na t]) : + Lemma ctx_inst_ass {Γ args na t} (c : ctx_inst Σ Γ args [vass na t]) : ∑ i, ((args = [i]) * (lift_typing typing Σ Γ i (Typ t)) * (ctx_inst_sub c = [i]))%type. Proof using Type. - depelim c; simpl in *. + depelim c; simpl in *. depelim c. exists i; constructor; auto. Qed. - Lemma ctx_inst_spine_subst {Γ Δ args} : + Lemma ctx_inst_spine_subst {Γ Δ args} : wf_local Σ (Γ ,,, Δ) -> forall ci : ctx_inst Σ Γ args (List.rev Δ), spine_subst Σ Γ args (ctx_inst_sub ci) Δ. @@ -1204,7 +1204,7 @@ Qed.*) pose proof (ctx_inst_sub_spec ci) as msub. eapply make_context_subst_spec in msub. rewrite List.rev_involutive in msub. - split; pcuic. now eapply wf_local_app_inv in wfΔ as []. + split; pcuic. now eapply wf_local_app_inv in wfΔ as []. move: ci msub. induction Δ in wfΔ, args |- *. simpl. intros ci. depelim ci. constructor. @@ -1235,7 +1235,7 @@ Qed.*) specialize (IHΔ _ wfΔ _ subr). constructor; auto. Qed. - Lemma spine_subst_ctx_inst {Γ Δ args s} : + Lemma spine_subst_ctx_inst {Γ Δ args s} : spine_subst Σ Γ args s Δ -> ctx_inst Σ Γ args (List.rev Δ). Proof using Type. @@ -1270,14 +1270,14 @@ Lemma subst_telescope_subst_context s k Γ : Proof. rewrite /subst_telescope subst_context_alt. rewrite rev_mapi. apply mapi_rec_ext. - intros n [na [b|] ty] le le'; rewrite /= /subst_decl /map_decl /=; - rewrite List.rev_length Nat.add_0_r in le'; + intros n [na [b|] ty] le le'; rewrite /= /subst_decl /map_decl /=; + rewrite List.rev_length Nat.add_0_r in le'; f_equal. f_equal. f_equal. lia. f_equal; lia. - f_equal; lia. + f_equal; lia. Qed. Lemma lift_context_subst_context n s Γ: lift_context n 0 (subst_context s 0 Γ) = - subst_context s n (lift_context n 0 Γ). + subst_context s n (lift_context n 0 Γ). Proof. induction Γ in n, s |- *. - reflexivity. @@ -1327,7 +1327,7 @@ Fixpoint all_rels (Γ : context) (n : nat) (k : nat) := Lemma all_rels_length Γ n k : #|all_rels Γ n k| = #|Γ|. Proof. induction Γ in n, k |- *; simpl; auto. - now destruct a as [? [?|] ?] => /=; simpl; rewrite IHΓ. + now destruct a as [? [?|] ?] => /=; simpl; rewrite IHΓ. Qed. Lemma nth_error_all_rels_spec Γ n k x i : nth_error (all_rels Γ n k) i = Some x -> @@ -1348,10 +1348,10 @@ Proof. eexists; split; eauto. simpl. now rewrite Nat.add_0_r. intros. destruct (decl_body a); try discriminate. - rewrite skipn_S. + rewrite skipn_S. specialize (IHΓ _ _ _ _ H). rewrite Nat.add_succ_r. apply IHΓ. - rewrite skipn_S. + rewrite skipn_S. specialize (IHΓ _ _ _ _ H). rewrite Nat.add_succ_r. apply IHΓ. Qed. @@ -1395,13 +1395,13 @@ Lemma all_rels_subst {cf:checker_flags} Σ Δ Γ t : Proof. intros wfΣ wf. assert(forall Γ' t (wf : wf_local Σ Γ'), - ((All_local_env_over typing - (fun Σ Γ' wfΓ' t T _ => - forall Γ Δ, Γ' = Γ ,,, Δ -> + ((All_local_env_over typing + (fun Σ Γ' wfΓ' t T _ => + forall Γ Δ, Γ' = Γ ,,, Δ -> red Σ.1 (Γ ,,, Δ) t (subst0 (all_rels Δ 0 #|Δ|) (lift #|Δ| #|Δ| t))) - Σ Γ' wf) * + Σ Γ' wf) * (match t with - | Some t => forall Γ Δ, Γ' = Γ ,,, Δ -> + | Some t => forall Γ Δ, Γ' = Γ ,,, Δ -> red Σ.1 (Γ ,,, Δ) t (subst0 (all_rels Δ 0 #|Δ|) (lift #|Δ| #|Δ| t)) | None => unit end))). clear t Δ Γ wf. intros Γ' t. @@ -1418,7 +1418,7 @@ Proof. - specialize (IH cf Σ wfΣ). destruct wf. constructor. - constructor. + constructor. apply (IH Γ t ltac:(left; simpl; lia) wf). intros; subst Γ. now apply (IH (Γ0 ,,, Δ) (Some t0) ltac:(left; simpl; lia) wf). @@ -1434,7 +1434,7 @@ Proof. specialize (IH cf Σ). assert (All_local_env_over typing (fun (Σ : PCUICEnvironment.global_env_ext) - (Γ'0 : PCUICEnvironment.context) (_ : wf_local Σ Γ'0) + (Γ'0 : PCUICEnvironment.context) (_ : wf_local Σ Γ'0) (t T : term) (_ : Σ;;; Γ'0 |- t : T) => forall Γ Δ : context, Γ'0 = Γ ,,, Δ -> @@ -1449,7 +1449,7 @@ Proof. rewrite -{3}(Nat.add_0_r #|Δ|). change 0 with #|@nil context_decl| at 2 3. generalize (@nil context_decl) as Δ'. - + induction t using term_ind_size_app; try solve [constructor]; intros Δ'. * simpl. destruct (leb_spec_Set (#|Δ| +#|Δ'|) n); simpl. @@ -1489,8 +1489,8 @@ Proof. rewrite app_length Hf. rewrite all_rels_lift. erewrite <-(simpl_lift _ _ _ _ #|skipn (S i) Δ|); try lia. - - epose proof (distr_lift_subst (lift #|skipn (S i) Δ| (#|Δ| - S i) t) + + epose proof (distr_lift_subst (lift #|skipn (S i) Δ| (#|Δ| - S i) t) (all_rels (skipn (S i) Δ) 0 #|skipn (S i) Δ|) (S i) 0). rewrite Nat.add_0_r in H. autorewrite with len in H. @@ -1508,7 +1508,7 @@ Proof. rewrite Hnth /= in wf. rewrite skipn_app in wf. replace (S i - #|Δ|) with 0 in wf. 2:lia. - rewrite skipn_0 in wf. + rewrite skipn_0 in wf. rewrite /on_local_decl /= in wf. move: wf => [] /subject_closed //. rewrite is_open_term_closed //. } @@ -1582,7 +1582,7 @@ Proof. autorewrite with len in b. rewrite Nat.add_shuffle3. now rewrite app_context_assoc in b. - + - specialize (X (Γ ,,, Δ) (Some t) wf). simpl in X. apply X. reflexivity. Qed. @@ -1652,7 +1652,7 @@ Section WfEnv. rewrite -app_assoc in IHc. specialize (IHc eql). destruct a as [na [?|] ?] => /=; rewrite lift_context_snoc /lift_decl /map_decl /=. - * rewrite app_length /= Nat.add_1_r in IHc. + * rewrite app_length /= Nat.add_1_r in IHc. rewrite all_rels_length Nat.add_0_r. intros X. specialize (IHc X). constructor; auto. @@ -1664,13 +1664,13 @@ Section WfEnv. rewrite -eql in l0. autorewrite with len in l0. simpl in l0. lia. eapply (substitution (Δ := []) IHc); auto. rewrite lift_context0_app !app_context_assoc in X. cbn in X. - eapply wf_local_app_inv in X as []. + eapply wf_local_app_inv in X as []. rewrite lift_context_snoc0 Nat.add_0_r /= in a. cbn in a. - depelim a. now cbn in l1. + depelim a. now cbn in l1. * rewrite app_length /= Nat.add_1_r in IHc. intros Hwf. specialize (IHc Hwf). constructor; auto. - + pose proof wf as wf'. rewrite -eql in wf'. rewrite !app_context_assoc in wf'. @@ -1682,7 +1682,7 @@ Section WfEnv. rewrite nth_error_app_ge // ?Nat.sub_diag //. destruct l0. exists x. - change (tSort x) with + change (tSort x) with (subst0 (all_rels c (S #|l|) #|Δ|) (lift #|Δ| #|c| (tSort x))). { eapply (substitution (Γ' := lift_context #|Δ| 0 c) (Δ := [])); cbn; auto. change (tSort x) with (lift #|Δ| #|c| (tSort x)). @@ -1691,8 +1691,8 @@ Section WfEnv. rewrite -{1}eql. simpl. rewrite !app_context_assoc. rewrite /app_context !app_assoc. - - epose proof (@all_rels_subst_lift c Γ + + epose proof (@all_rels_subst_lift c Γ (l ++ [{|decl_name := na; decl_body := None; decl_type := decl_type|}]) decl_type). assert (#|Δ| = #|c| + S #|l|). { rewrite -eql. autorewrite with len. simpl. lia. } @@ -1722,7 +1722,7 @@ Section WfEnv. Lemma type_it_mkProd_or_LetIn_inv {Γ Δ t s} : Σ ;;; Γ |- it_mkProd_or_LetIn Δ t : tSort s -> - ∑ Δs ts, + ∑ Δs ts, [× sorts_local_ctx (lift_typing typing) Σ Γ Δ Δs, Σ ;;; Γ ,,, Δ |- t : tSort ts, wf_universe Σ s & @@ -1740,7 +1740,7 @@ Section WfEnv. splits; eauto. now eexists. eapply (type_ws_cumul_pb (pb:=Cumul)). eapply t2. apply isType_Sort; pcuic. eapply ws_cumul_pb_LetIn_l_inv in e; auto. - eapply ws_cumul_pb_Sort_r_inv in e as [u' [redu' cumu']]. + eapply ws_cumul_pb_Sort_r_inv in e as [u' [redu' cumu']]. transitivity (tSort u'). 2:{ eapply ws_cumul_pb_compare; eauto with fvs. eapply typing_wf_local in t2. eauto with fvs. @@ -1762,15 +1762,15 @@ Section WfEnv. exists (x :: Δs), x0. splits; tea. eapply ws_cumul_pb_Sort_inv in e. transitivity (sort_of_products Δs ts); auto using leq_universe_product. - simpl. eapply leq_universe_sort_of_products_mon. + simpl. eapply leq_universe_sort_of_products_mon. eapply Forall2_same. reflexivity. exact: e. Qed. - - Lemma leq_universe_sort_of_products {u v} : + + Lemma leq_universe_sort_of_products {u v} : leq_universe Σ v (sort_of_products u v). Proof using Type. - induction u; simpl; auto. + induction u; simpl; auto. - reflexivity. - etransitivity; tea. eapply leq_universe_sort_of_products_mon => //. @@ -1789,8 +1789,8 @@ Section WfEnv. apply leq_universe_sort_of_products. Qed. - Lemma isType_it_mkProd_or_LetIn_app {Γ Δ Δ' args T s} : - Σ ;;; Γ |- it_mkProd_or_LetIn (Δ ,,, Δ') T : tSort s -> + Lemma isType_it_mkProd_or_LetIn_app {Γ Δ Δ' args T s} : + Σ ;;; Γ |- it_mkProd_or_LetIn (Δ ,,, Δ') T : tSort s -> subslet Σ Γ args (smash_context [] Δ) -> Σ ;;; Γ |- subst_let_expand args Δ (it_mkProd_or_LetIn Δ' T) : tSort s. Proof using wfΣ. @@ -1801,7 +1801,7 @@ Section WfEnv. eapply (PCUICSubstitution.substitution (Δ := [])) in Hs; tea. Qed. - Lemma lift_to_extended_list_k n Γ : map (lift n #|Γ|) (to_extended_list_k Γ 0) = + Lemma lift_to_extended_list_k n Γ : map (lift n #|Γ|) (to_extended_list_k Γ 0) = to_extended_list_k Γ 0. Proof using Type. rewrite /to_extended_list_k. @@ -1821,9 +1821,9 @@ Section WfEnv. destruct (leb_spec_Set (S (#|Γ| + n')) n'). lia. reflexivity. Qed. - - Lemma reln_subst acc s Γ k : - reln (map (subst s (k + #|Γ|)) acc) k (subst_context s 0 Γ) = + + Lemma reln_subst acc s Γ k : + reln (map (subst s (k + #|Γ|)) acc) k (subst_context s 0 Γ) = map (subst s (k + #|Γ|)) (reln acc k Γ). Proof using Type. induction Γ in acc, s, k |- *; simpl; auto. @@ -1846,7 +1846,7 @@ Section WfEnv. now rewrite subst_telescope_subst_context List.rev_involutive. Qed. - Lemma ctx_inst_sub_to_extended_list_k Γ args Δ : + Lemma ctx_inst_sub_to_extended_list_k Γ args Δ : forall inst : ctx_inst Σ Γ args Δ, map (subst0 (ctx_inst_sub inst)) (to_extended_list_k (List.rev Δ) 0) = args. Proof using Type. @@ -1881,7 +1881,7 @@ Section WfEnv. now rewrite List.rev_length len. Qed. - Lemma spine_subst_subst_to_extended_list_k {Γ args s Δ} : + Lemma spine_subst_subst_to_extended_list_k {Γ args s Δ} : spine_subst Σ Γ args s Δ -> map (subst0 s) (to_extended_list_k Δ 0) = args. Proof using Type. @@ -1921,8 +1921,8 @@ Section WfEnv. rewrite simpl_subst_k //. Qed. - Lemma spine_subst_subst_to_extended_list_k_gen {Γ args s Δ Δ'} : - spine_subst Σ Γ args s Δ -> + Lemma spine_subst_subst_to_extended_list_k_gen {Γ args s Δ Δ'} : + spine_subst Σ Γ args s Δ -> to_extended_list_k Δ 0 = to_extended_list_k Δ' 0 -> map (subst0 s) (to_extended_list_k Δ' 0) = args. Proof using Type. @@ -1941,7 +1941,7 @@ Section WfEnv. move/typing_spine_isType_dom; pcuic. Qed. Hint Resolve typing_spine_wf_local : pcuic. - + Lemma substitution_ws_cumul_pb_vass {pb : conv_pb} {Γ} {a na ty M N} : Σ ;;; Γ |- a : ty -> Σ ;;; Γ,, vass na ty ⊢ M ≤[pb] N -> @@ -1961,7 +1961,7 @@ Section WfEnv. eapply subslet_def_tip. now depelim ha. Qed. - Lemma subst0_it_mkProd_or_LetIn s Γ T : subst s 0 (it_mkProd_or_LetIn Γ T) = + Lemma subst0_it_mkProd_or_LetIn s Γ T : subst s 0 (it_mkProd_or_LetIn Γ T) = it_mkProd_or_LetIn (subst_context s 0 Γ) (subst s #|Γ| T). Proof using Type. now rewrite subst_it_mkProd_or_LetIn Nat.add_0_r. @@ -1981,7 +1981,7 @@ Section WfEnv. - intros _ T sp; exists []. split; [repeat constructor|.. ]; auto; rewrite ?subst_empty //. all:pcuic. - rewrite context_assumptions_app => eq T sp. - assert (wfΓΔ := isType_it_mkProd_or_LetIn_wf_local (Δ := Δ ++ [d]) + assert (wfΓΔ := isType_it_mkProd_or_LetIn_wf_local (Δ := Δ ++ [d]) (typing_spine_isType_dom sp)). rewrite it_mkProd_or_LetIn_app in sp. destruct d as [? [b|] ?]; simpl in *. @@ -2023,7 +2023,7 @@ Section WfEnv. { eapply (type_ws_cumul_pb (pb:=Conv)); tea. 2:now symmetry. now eapply isType_tProd in isty as []. } eapply isType_apply in isty; tea. - eapply typing_spine_strengthen in sp. 3:tea. 2:tas. + eapply typing_spine_strengthen in sp. 3:tea. 2:tas. rewrite /subst1 subst0_it_mkProd_or_LetIn in sp; auto. specialize (X sp). destruct X as [args_sub [sps sp']]. @@ -2081,11 +2081,11 @@ Section WfEnv. econstructor; eauto. Qed. - Lemma typing_spine_nth_error {Γ Δ T args n arg concl} : + Lemma typing_spine_nth_error {Γ Δ T args n arg concl} : typing_spine Σ Γ (it_mkProd_or_LetIn Δ T) args concl -> nth_error args n = Some arg -> (n < context_assumptions Δ) -> - ∑ decl, (nth_error (smash_context [] Δ) (context_assumptions Δ - S n) = Some decl) * + ∑ decl, (nth_error (smash_context [] Δ) (context_assumptions Δ - S n) = Some decl) * (Σ ;;; Γ |- arg : subst0 (List.rev (firstn n args)) (decl_type decl)). Proof using wfΣ. revert n args T. @@ -2103,7 +2103,7 @@ Section WfEnv. rewrite smash_context_app. simpl. now rewrite -(smash_context_subst []) /= subst_context_nil. + simpl. - move=> sp. + move=> sp. dependent elimination sp as [spnil _ _ _|spcons isty isty' e e' sp]; rewrite ?nth_error_nil //. destruct n as [|n']; simpl. * move=> [=] eq; subst hd0. @@ -2142,7 +2142,7 @@ Section WfEnv. rewrite nth_error_app_context_lt ?smash_context_length. lia. destruct (nth_error (smash_context [] Γ0) _) eqn:Heq; try discriminate. simpl in Hnth'. exists c; split; auto. - noconf Hnth'. + noconf Hnth'. rewrite /= smash_context_length /= in Hty. replace ((context_assumptions Γ0 - S (context_assumptions Γ0 - S n') + 0)) with n' in Hty by lia. @@ -2155,7 +2155,7 @@ Section WfEnv. Local Open Scope sigma. - Lemma spine_subst_smash {Γ inst s Δ} : + Lemma spine_subst_smash {Γ inst s Δ} : spine_subst Σ Γ inst s Δ -> spine_subst Σ Γ inst (List.rev inst) (smash_context [] Δ). Proof using wfΣ. @@ -2256,12 +2256,12 @@ Section WfEnv. len. intros n [? [?|] ?]; unfold lift_decl, subst_decl, map_decl; simpl. generalize (Nat.pred #|Γ| - n). - intros. + intros. now rewrite !Nat.add_succ_r !subst_rel0_lift_id. now rewrite !Nat.add_succ_r !subst_rel0_lift_id. Qed. - Lemma subst_extended_subst s Γ : extended_subst (subst_context s 0 Γ) 0 = + Lemma subst_extended_subst s Γ : extended_subst (subst_context s 0 Γ) 0 = map (subst s (context_assumptions Γ)) (extended_subst Γ 0). Proof using Type. induction Γ as [|[na [b|] ty] Γ]; simpl; auto; rewrite subst_context_snoc /=; @@ -2269,9 +2269,9 @@ Section WfEnv. - rewrite IHΓ. rewrite commut_lift_subst_rec. auto. rewrite distr_subst. now autorewrite with len. - - rewrite IHΓ. + - rewrite IHΓ. rewrite !map_map_compose. apply map_ext. - intros x. + intros x. erewrite (commut_lift_subst_rec). lia_f_equal. lia. Qed. @@ -2300,9 +2300,9 @@ Section WfEnv. autorewrite with len. rewrite simpl_lift; lia_f_equal. Qed. - Lemma arity_spine_it_mkProd_or_LetIn_smash {Γ Δ T args args' T'} : + Lemma arity_spine_it_mkProd_or_LetIn_smash {Γ Δ T args args' T'} : subslet Σ Γ (List.rev args) (smash_context [] Δ) -> - arity_spine Σ Γ (subst_let_expand (List.rev args) Δ T) args' T' -> + arity_spine Σ Γ (subst_let_expand (List.rev args) Δ T) args' T' -> arity_spine Σ Γ (it_mkProd_or_LetIn Δ T) (args ++ args') T'. Proof using Type. intros subsl asp. @@ -2318,7 +2318,7 @@ Section WfEnv. * constructor. rewrite /subst1 subst_it_mkProd_or_LetIn. rewrite Nat.add_0_r. rewrite smash_context_app smash_context_acc /= in subsl. - rewrite lift0_id /= subst_context_nil app_nil_r + rewrite lift0_id /= subst_context_nil app_nil_r lift0_context in subsl. rewrite -(smash_context_subst []) /= subst_context_nil in subsl. rewrite subst_empty in subsl. @@ -2332,7 +2332,7 @@ Section WfEnv. simpl in asp. autorewrite with len. now rewrite -{1}(Nat.add_0_r #|Γ0|) distr_lift_subst_rec /= Nat.add_0_r. - * simpl in *. len in asp. + * simpl in *. len in asp. simpl in asp. assert (len:=subslet_length subsl). len in len. simpl in len. @@ -2340,7 +2340,7 @@ Section WfEnv. rewrite smash_context_app smash_context_acc /= in subsl. rewrite subst_context_lift_id in subsl. eapply subslet_app_inv in subsl as [subsl subsr]. - destruct args; simpl in * => //. + destruct args; simpl in * => //. noconf len. len in subsl; len in subsr. simpl in *. rewrite -H in subsl subsr. rewrite skipn_all_app_eq ?List.rev_length in subsl subsr => //. @@ -2370,12 +2370,12 @@ Section WfEnv. now rewrite subst_extended_subst H. Qed. - (** This shows that we can promote an argument spine for a given context to + (** This shows that we can promote an argument spine for a given context to a spine for a context whose types are higher in the cumulativity relation. *) - Lemma subslet_cumul {pb Δ args Γ Γ'} : - assumption_context Γ -> assumption_context Γ' -> + Lemma subslet_cumul {pb Δ args Γ Γ'} : + assumption_context Γ -> assumption_context Γ' -> wf_local Σ (Δ ,,, Γ) -> wf_local Σ (Δ ,,, Γ') -> ws_cumul_ctx_pb_rel pb Σ Δ Γ Γ' -> @@ -2401,19 +2401,19 @@ Section WfEnv. eapply (PCUICConversion.substitution_ws_cumul_pb (s:=s) (Γ' := Γ) (Γ'' := [])); eauto. Qed. - Lemma spine_subst_cumul {Δ args Γ Γ'} : - assumption_context Γ -> assumption_context Γ' -> + Lemma spine_subst_cumul {Δ args Γ Γ'} : + assumption_context Γ -> assumption_context Γ' -> wf_local Σ (Δ ,,, Γ) -> wf_local Σ (Δ ,,, Γ') -> ws_cumul_ctx_pb_rel Cumul Σ Δ Γ Γ' -> - spine_subst Σ Δ args (List.rev args) Γ -> + spine_subst Σ Δ args (List.rev args) Γ -> spine_subst Σ Δ args (List.rev args) Γ'. Proof using wfΣ. intros ass ass' wf wf' a2. intros []; split; auto. - clear -a2 ass ass' inst_ctx_subst0. revert inst_ctx_subst0; generalize (List.rev args). - intros l ctxs. + intros l ctxs. induction ctxs in ass, Γ', ass', a2 |- *; depelim a2; try (simpl in H; noconf H); try constructor; auto. * depelim a. constructor. * depelim a. depelim a0. econstructor. eapply IHctxs. now depelim ass. @@ -2440,7 +2440,7 @@ Section WfEnv. Lemma pre_type_mkApps_arity {Γ t u tty T} : Σ;;; Γ |- t : tty -> isType Σ Γ tty -> - arity_spine Σ Γ tty u T -> + arity_spine Σ Γ tty u T -> Σ;;; Γ |- mkApps t u : T. Proof using wfΣ. intros Ht Hty Har. @@ -2449,8 +2449,8 @@ Section WfEnv. constructor; tas. Qed. - Lemma map_subst_extended_subst Γ k : - map (subst0 (List.rev (to_extended_list_k Γ k))) (extended_subst Γ 0) = + Lemma map_subst_extended_subst Γ k : + map (subst0 (List.rev (to_extended_list_k Γ k))) (extended_subst Γ 0) = all_rels Γ k 0. Proof using Type. unfold to_extended_list_k. @@ -2462,7 +2462,7 @@ Section WfEnv. rewrite simpl_subst_k. len. rewrite IHΓ. now rewrite Nat.add_1_r. rewrite IHΓ. now rewrite Nat.add_1_r. - rewrite reln_acc List.rev_app_distr /=. + rewrite reln_acc List.rev_app_distr /=. rewrite (map_subst_app_decomp [tRel k]). simpl. f_equal. rewrite lift_extended_subst. rewrite map_map_compose -IHΓ. apply map_ext. @@ -2480,12 +2480,12 @@ Section WfEnv. epose proof (distr_subst_rec _ _ _ 0 _). rewrite Nat.add_0_r in H. rewrite -> H. clear H. len. - rewrite simpl_subst_k. now len. + rewrite simpl_subst_k. now len. now rewrite map_subst_extended_subst. Qed. Lemma expand_lets_ctx_o_lets Γ k k' Δ : - subst_context (List.rev (to_extended_list_k Γ k)) k' (expand_lets_k_ctx Γ k' Δ) = + subst_context (List.rev (to_extended_list_k Γ k)) k' (expand_lets_k_ctx Γ k' Δ) = subst_context (all_rels Γ k 0) k' Δ. Proof using Type. revert k k'; induction Δ using rev_ind; simpl; auto. @@ -2498,15 +2498,15 @@ Section WfEnv. destruct decl_body; simpl in * => //. unfold subst_context, fold_context_k; simpl. f_equal. - unfold expand_lets_k, subst_context => /=. + unfold expand_lets_k, subst_context => /=. unfold map_decl; simpl. unfold map_decl. simpl. f_equal. destruct (decl_body x); simpl. f_equal. now rewrite subst_ext_list_ext_subst. auto. now rewrite subst_ext_list_ext_subst. Qed. - Lemma subst_subst_context s k s' Γ : - subst_context s k (subst_context s' 0 Γ) = + Lemma subst_subst_context s k s' Γ : + subst_context s k (subst_context s' 0 Γ) = subst_context (map (subst s k) s') 0 (subst_context s (#|s'| + k) Γ). Proof using Type. rewrite !subst_context_alt. @@ -2527,10 +2527,10 @@ Section WfEnv. rewrite subst_context_snoc /snoc /= IHctx // subst_decl_closed //. Qed. - Lemma expand_lets_k_ctx_subst_id' Γ k Δ : + Lemma expand_lets_k_ctx_subst_id' Γ k Δ : closed_ctx Γ -> - closedn_ctx #|Γ| Δ -> - expand_lets_k_ctx Γ k (subst_context (List.rev (to_extended_list_k Γ k)) 0 + closedn_ctx #|Γ| Δ -> + expand_lets_k_ctx Γ k (subst_context (List.rev (to_extended_list_k Γ k)) 0 (expand_lets_ctx Γ Δ)) = subst_context (List.rev (to_extended_list_k (smash_context [] Γ) k)) 0 (expand_lets_ctx Γ Δ). @@ -2565,7 +2565,7 @@ Section WfEnv. apply map_ext. apply subst_lift1. Qed. - Lemma subst_extended_lift Γ k : + Lemma subst_extended_lift Γ k : closed_ctx Γ -> map (subst0 (List.rev (to_extended_list_k (smash_context [] Γ) k))) (extended_subst Γ 0) = extended_subst Γ k. @@ -2608,9 +2608,9 @@ Section WfEnv. now rewrite !Upn_subst_consn_lt; len; try lia. Qed. - Lemma subst_map_lift_lift_context (Γ : context) k s : + Lemma subst_map_lift_lift_context (Γ : context) k s : closedn_ctx #|s| Γ -> - subst_context (map (lift0 k) s) 0 Γ = + subst_context (map (lift0 k) s) 0 Γ = subst_context s k (lift_context k 0 Γ). Proof using Type. induction Γ as [|[? [] ?] ?] in k |- *; intros cl; auto; @@ -2628,13 +2628,13 @@ Section WfEnv. lia_f_equal. Qed. - Lemma subst_context_lift_context_comm (Γ : context) n k k' s : + Lemma subst_context_lift_context_comm (Γ : context) n k k' s : k' = k + n -> subst_context s k' (lift_context n k Γ) = lift_context n k (subst_context s k Γ). Proof using Type. intros ->; induction Γ as [|[? [] ?] ?] in |- *; auto; - rewrite !lift_context_snoc !subst_context_snoc !lift_context_snoc /= + rewrite !lift_context_snoc !subst_context_snoc !lift_context_snoc /= /subst_decl /lift_decl /map_decl /=. - rewrite IHΓ //. f_equal. f_equal. f_equal; len. rewrite commut_lift_subst_rec. lia. lia_f_equal. @@ -2645,7 +2645,7 @@ Section WfEnv. lia_f_equal. Qed. - Lemma context_subst_subst_extended_subst inst s Δ : + Lemma context_subst_subst_extended_subst inst s Δ : context_subst Δ inst s -> s = map (subst0 (List.rev inst)) (extended_subst Δ 0). Proof using Type. @@ -2669,7 +2669,7 @@ Section WfEnv. now rewrite lift0_id. Qed. - Lemma spine_subst_extended_subst {Γ inst s Δ} : + Lemma spine_subst_extended_subst {Γ inst s Δ} : spine_subst Σ Γ inst s Δ -> s = map (subst0 (List.rev inst)) (extended_subst Δ 0). Proof using Type. @@ -2691,7 +2691,7 @@ Section WfEnv. rewrite skipn_all_app_eq; try lia. auto. rewrite (firstn_app_left) ?Nat.add_0_r // firstn_0 // app_nil_r //. rewrite -(firstn_skipn #|Δ'| insts). - eapply subslet_app; auto. + eapply subslet_app; auto. Qed. Lemma context_assumptions_lift {n k Γ} : context_assumptions (lift_context n k Γ) = context_assumptions Γ. Proof using Type. apply context_assumptions_fold. Qed. @@ -2699,7 +2699,7 @@ Section WfEnv. Proof using Type. apply context_assumptions_fold. Qed. Hint Rewrite @context_assumptions_lift @context_assumptions_subst : len. - Lemma ws_cumul_ctx_pb_rel'_context_assumptions {pb} {Γ} {Δ Δ'} : + Lemma ws_cumul_ctx_pb_rel'_context_assumptions {pb} {Γ} {Δ Δ'} : All2_fold (fun Γ' _ : context => All_decls_alpha_pb pb @@ -2710,21 +2710,21 @@ Section WfEnv. depelim p; simpl; auto. lia. Qed. - Lemma ws_cumul_ctx_pb_rel_context_assumptions {pb} {Γ} {Δ Δ'} : + Lemma ws_cumul_ctx_pb_rel_context_assumptions {pb} {Γ} {Δ Δ'} : ws_cumul_ctx_pb_rel pb Σ Γ Δ Δ' -> context_assumptions Δ = context_assumptions Δ'. Proof using Type. intros []. now eapply ws_cumul_ctx_pb_rel'_context_assumptions. Qed. - + (* Lemma subslet_subs {cf} {Σ} {wfΣ : wf Σ} {Γ i Δ Δ'} : ws_cumul_ctx_pb_rel pb Σ Γ Δ Δ' -> ctx_inst Σ Γ i (Li *) - Lemma ws_cumul_pb_expand_lets_k {pb} {Γ Δ Γ'} {T T'} : + Lemma ws_cumul_pb_expand_lets_k {pb} {Γ Δ Γ'} {T T'} : wf_local Σ (Γ ,,, Δ) -> Σ ;;; Γ ,,, Δ ,,, Γ' ⊢ T ≤[pb] T' -> - Σ ;;; Γ ,,, smash_context [] Δ ,,, expand_lets_ctx Δ Γ' ⊢ + Σ ;;; Γ ,,, smash_context [] Δ ,,, expand_lets_ctx Δ Γ' ⊢ expand_lets_k Δ #|Γ'| T ≤[pb] expand_lets_k Δ #|Γ'| T'. Proof using wfΣ. intros wf cum. @@ -2742,7 +2742,7 @@ Section WfEnv. eapply wf_local_smash_end in wf. eauto with fvs. Qed. - Lemma ws_cumul_pb_expand_lets {pb} {Γ} {Δ} {T T'} : + Lemma ws_cumul_pb_expand_lets {pb} {Γ} {Δ} {T T'} : wf_local Σ (Γ ,,, Δ) -> Σ ;;; Γ ,,, Δ ⊢ T ≤[pb] T' -> Σ ;;; Γ ,,, smash_context [] Δ ⊢ expand_lets Δ T ≤[pb] expand_lets Δ T'. @@ -2777,7 +2777,7 @@ Section WfEnv. eapply ws_cumul_pb_eq_le. Qed. - Lemma ws_cumul_ctx_pb_le_le {pb Γ Γ'} : + Lemma ws_cumul_ctx_pb_le_le {pb Γ Γ'} : Σ ⊢ Γ ≤[pb] Γ' -> Σ ⊢ Γ ≤ Γ'. Proof using Type. intros a; eapply All2_fold_impl; tea. @@ -2873,7 +2873,7 @@ Section WfEnv. constructor; auto. len. eapply ws_cumul_pb_expand_lets in eqb; tea. - etransitivity; tea. + etransitivity; tea. rewrite /expand_lets /expand_lets_k. simpl. rewrite -(length_of cum). rewrite -(ws_cumul_ctx_pb_rel'_context_assumptions cum). @@ -2933,7 +2933,7 @@ Section WfEnv. #|Δ| = #|Δ'|. Proof using Type. intros []. apply (length_of a). Qed. - Lemma is_closed_context_smash_end {Γ Δ} : + Lemma is_closed_context_smash_end {Γ Δ} : is_closed_context (Γ ,,, Δ) -> is_closed_context (Γ ,,, smash_context [] Δ). Proof using Type. @@ -2944,7 +2944,7 @@ Section WfEnv. Hint Resolve is_closed_context_smash_end : fvs. - Lemma ws_cumul_pb_expand_lets_ws_cumul_ctx {pb le'} {Γ} {Δ Δ'} {T T'} : + Lemma ws_cumul_pb_expand_lets_ws_cumul_ctx {pb le'} {Γ} {Δ Δ'} {T T'} : wf_local Σ (Γ ,,, Δ) -> wf_local Σ (Γ ,,, Δ') -> Σ ;;; Γ ,,, Δ ⊢ T ≤[le'] T' -> @@ -2980,13 +2980,13 @@ Section WfEnv. ctx_inst Σ Γ i (List.rev Δ'). Proof using wfΣ. intros [clΓ a]. - induction a in i |- *; intros ci. + induction a in i |- *; intros ci. - depelim ci. constructor. - simpl in ci. eapply PCUICSpine.ctx_inst_app_inv in ci as [dom codom]. depelim p. * simpl in codom. depelim codom. simpl in codom. depelim codom. cbn in t1. - destruct i as [|i t0] using rev_case. + destruct i as [|i t0] using rev_case. { rewrite skipn_nil in H => //. } assert (context_assumptions (List.rev Γ0) = #|i|). apply (f_equal (@length _)) in H. simpl in H. @@ -3024,7 +3024,7 @@ Section WfEnv. eapply ws_cumul_pb_expand_lets_ws_cumul_ctx; tea. now eapply typing_wf_local in Hs. split; tea. * simpl in codom. depelim codom. - simpl in codom. depelim codom. + simpl in codom. depelim codom. assert (context_assumptions (List.rev Γ0) = #|i|). pose proof (ctx_inst_length dom). apply (f_equal (@length _)) in H. simpl in H. @@ -3052,12 +3052,12 @@ Section WfEnv. reflexivity. Qed. - Lemma ctx_inst_smash_acc {Γ i Δ} : - ctx_inst Σ Γ i Δ <~> + Lemma ctx_inst_smash_acc {Γ i Δ} : + ctx_inst Σ Γ i Δ <~> ctx_inst Σ Γ i (List.rev (smash_context [] (List.rev Δ))). Proof using Type. split. - - induction 1. + - induction 1. + constructor. + simpl. rewrite smash_context_app_ass. len. @@ -3083,8 +3083,8 @@ Section WfEnv. now rewrite subst_context_rev_subst_telescope in ctxi. Qed. - Lemma ctx_inst_smash {Γ i Δ} : - ctx_inst Σ Γ i (List.rev Δ) <~> + Lemma ctx_inst_smash {Γ i Δ} : + ctx_inst Σ Γ i (List.rev Δ) <~> ctx_inst Σ Γ i (List.rev (smash_context [] Δ)). Proof using Type. split; intros. @@ -3097,7 +3097,7 @@ Section WfEnv. Proof using Type. rewrite /subst_telescope subst_context_alt. rewrite rev_mapi. apply mapi_rec_ext. - intros n [na [b|] ty] le le'; rewrite /= /subst_decl /map_decl /=; + intros n [na [b|] ty] le le'; rewrite /= /subst_decl /map_decl /=; rewrite List.rev_length Nat.add_0_r in le'; len; lia_f_equal. Qed. @@ -3132,7 +3132,7 @@ Section WfEnv. - depelim o. constructor. apply t0. auto. rewrite -(List.rev_involutive Δ). rewrite subst_telescope_subst_context. - simpl in wf. rewrite - !/(app_context _ _) app_context_assoc in wf. + simpl in wf. rewrite - !/(app_context _ _) app_context_assoc in wf. eapply ctx_inst_cumul. 2:{ instantiate (1:=subst_context [i] 0 (List.rev Δ)). rewrite -subst_telescope_subst_context List.rev_involutive. exact ctxi. } @@ -3179,7 +3179,7 @@ Section WfEnv. - depelim o. constructor. apply t0. auto. rewrite -(List.rev_involutive Δ). rewrite subst_telescope_subst_context. - simpl in wf. rewrite - !/(app_context _ _) app_context_assoc in wf. + simpl in wf. rewrite - !/(app_context _ _) app_context_assoc in wf. eapply ctx_inst_cumul. 2:{ instantiate (1:=subst_context [i] 0 (List.rev Δ)). rewrite -subst_telescope_subst_context List.rev_involutive. eapply IHc => //. @@ -3203,14 +3203,14 @@ Section WfEnv. eapply wf_local_app_inv in wf as [wf _]. now depelim wf. Qed. - Lemma ctx_inst_open_terms Γ args Δ : + Lemma ctx_inst_open_terms Γ args Δ : ctx_inst Σ Γ args Δ -> All (is_open_term Γ) args. Proof using wfΣ. induction 1; try constructor; eauto using subject_is_open_term. Qed. - - Lemma subslet_open_terms Γ s Δ : + + Lemma subslet_open_terms Γ s Δ : subslet Σ Γ s Δ -> All (is_open_term Γ) s. Proof using wfΣ. @@ -3221,8 +3221,8 @@ Section WfEnv. wf_local Σ (Γ ,,, List.rev Δ) -> PCUICTyping.ctx_inst (fun (Σ : global_env_ext) (Γ : context) (u A : term) => - forall v : term, upto_names' u v -> Σ;;; Γ |- v : A) Σ Γ args Δ -> - ctx_inst Σ Γ args Δ -> + forall v : term, upto_names' u v -> Σ;;; Γ |- v : A) Σ Γ args Δ -> + ctx_inst Σ Γ args Δ -> All2 upto_names' args args' -> ctx_inst Σ Γ args' Δ. Proof using wfΣ. diff --git a/pcuic/theories/PCUICSubstitution.v b/pcuic/theories/PCUICSubstitution.v index 644d7960a..d09afe8f1 100644 --- a/pcuic/theories/PCUICSubstitution.v +++ b/pcuic/theories/PCUICSubstitution.v @@ -2,7 +2,7 @@ From MetaCoq.Template Require Import utils config. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICInduction PCUICLiftSubst PCUICEquality PCUICPosition PCUICCases PCUICSigmaCalculus - PCUICUnivSubst PCUICContextSubst PCUICTyping + PCUICUnivSubst PCUICContextSubst PCUICTyping PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICClosed PCUICClosedConv PCUICClosedTyp PCUICReduction PCUICWeakeningConv PCUICWeakeningTyp PCUICCumulativity PCUICUnivSubstitutionConv PCUICRenameDef PCUICRenameConv PCUICInstDef PCUICInstConv PCUICInstTyp PCUICOnFreeVars. @@ -10,7 +10,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICInduc Require Import ssreflect. From Equations Require Import Equations. -(** * Substitution lemmas for typing derivations. Substitution is now derived from a general +(** * Substitution lemmas for typing derivations. Substitution is now derived from a general instantiation lemma, but the rest of the theory is using substituion lemmas instead of the slightly more general but also more technical instantiation lemmas. *) @@ -53,7 +53,7 @@ Inductive subslet {cf:checker_flags} Σ (Γ : context) : list term -> context -> #[global] Hint Constructors subslet : pcuic. -Lemma subslet_def {cf} {Σ : global_env_ext} {Γ Δ s na t T t'} : +Lemma subslet_def {cf} {Σ : global_env_ext} {Γ Δ s na t T t'} : subslet Σ Γ s Δ -> Σ;;; Γ |- subst0 s t : subst0 s T -> t' = subst0 s t -> @@ -62,7 +62,7 @@ Proof. now intros sub Ht ->; constructor. Qed. -Lemma subslet_ass_tip {cf} {Σ : global_env_ext} {Γ na t T} : +Lemma subslet_ass_tip {cf} {Σ : global_env_ext} {Γ na t T} : Σ;;; Γ |- t : T -> subslet Σ Γ [t] [vass na T]. Proof. @@ -70,7 +70,7 @@ Proof. now rewrite !subst_empty. Qed. -Lemma subslet_def_tip {cf} {Σ : global_env_ext} {Γ na t T} : +Lemma subslet_def_tip {cf} {Σ : global_env_ext} {Γ na t T} : Σ;;; Γ |- t : T -> subslet Σ Γ [t] [vdef na t T]. Proof. @@ -78,7 +78,7 @@ Proof. all:now rewrite !subst_empty. Qed. -#[global] Hint Resolve subslet_ass_tip subslet_def_tip : pcuic. +#[global] Hint Resolve subslet_ass_tip subslet_def_tip : pcuic. Lemma subslet_nth_error {cf:checker_flags} {Σ Γ s Δ decl n} : subslet Σ Γ s Δ -> @@ -215,7 +215,7 @@ Proof. erewrite nth_error_subst_context. f_equal. unfold subst_decl. rewrite Nat.add_0_r. reflexivity. Qed. -Lemma expand_lets_subst_comm' Γ s k x : +Lemma expand_lets_subst_comm' Γ s k x : closedn (k + #|Γ|) x -> expand_lets (subst_context s k Γ) x = subst s (k + context_assumptions Γ) (expand_lets Γ x). Proof. @@ -246,7 +246,7 @@ Proof. - eapply map_ext => ?. now rewrite subst_inst. - now rewrite /inst_branch /map_branch_k subst_inst up_Upn Upn_Upn. Qed. - + Lemma subst_unfold_fix n k mfix idx narg fn : unfold_fix mfix idx = Some (narg, fn) -> unfold_fix (map (map_def (subst n k) (subst n (#|mfix| + k))) mfix) idx = Some (narg, subst n k fn). @@ -1183,14 +1183,14 @@ Proof. pose proof (untyped_subslet_length subs). rewrite Upn_eq {1}/subst_consn nth_error_idsn_None; try lia. len. rewrite subst_consn_compose subst_consn_lt; len; try lia. - rewrite /subst_fn nth_error_map. + rewrite /subst_fn nth_error_map. case: nth_error_spec; try lia. move=> x hs hns /=. epose proof (untyped_subslet_nth_error _ _ _ _ _ _ subs hnth hs). rewrite hb in X; rewrite X; cbn. rewrite subst_inst Upn_0 inst_assoc. apply inst_ext. (rewrite skipn_subst; try by lia); []. rewrite !subst_compose_assoc. - rewrite subst_consn_compose. sigma. + rewrite subst_consn_compose. sigma. rewrite -subst_compose_assoc -shiftk_shift -subst_compose_assoc. rewrite -shiftk_shift. (rewrite (shift_subst_consn_ge (S n)); try by len; lia); []. @@ -1232,13 +1232,13 @@ Lemma subst_compare_term {cf:checker_flags} le Σ (φ : ConstraintSet.t) (l : li Proof. destruct le; simpl. - apply subst_eq_term. - - apply subst_leq_term. + - apply subst_leq_term. Qed. Lemma subst_compare_decl `{checker_flags} {le Σ ϕ l k d d'} : compare_decl le Σ ϕ d d' -> compare_decl le Σ ϕ (subst_decl l k d) (subst_decl l k d'). Proof. - intros []; constructor; auto; destruct le; + intros []; constructor; auto; destruct le; intuition eauto using subst_compare_term, subst_eq_term, subst_leq_term. Qed. @@ -1278,7 +1278,7 @@ Section CtxReduction. Qed. End CtxReduction. -Record wt_cumul_pb {cf} (c : conv_pb) Σ (Γ : context) T U := +Record wt_cumul_pb {cf} (c : conv_pb) Σ (Γ : context) T U := { wt_cumul_pb_dom : isType Σ Γ T; wt_cumul_pb_codom : isType Σ Γ U; wt_cumul_pb_eq : cumulAlgo_gen Σ Γ c T U }. @@ -1301,7 +1301,7 @@ Definition wt_conv_conv {cf} {Σ Γ T U} : Σ ;;; Γ |- T = U ✓ -> Σ ;;; Γ | Proof. intros H; apply (wt_cumul_pb_eq H). Defined. Coercion wt_conv_conv : wt_conv >-> convAlgo. -Definition red1P P Σ Γ t v := +Definition red1P P Σ Γ t v := on_ctx_free_vars P Γ × on_free_vars P t × red1 Σ Γ t v. Definition red1P_red1 {P Σ Γ t v} : red1P P Σ Γ t v -> red1 Σ Γ t v := fun x => x.2.2. @@ -1378,7 +1378,7 @@ Section SubstitutionLemmas. now eapply red1_on_free_vars. * econstructor; [|split]; tea. } Qed. - + Lemma substitution_red1 {Γ Γ' Γ'' s M N} : subs Σ Γ s Γ' -> wf_local Σ Γ -> is_open_term (Γ,,, Γ',,, Γ'') M -> @@ -1441,7 +1441,7 @@ Section SubstitutionLemmas. - etransitivity; [eapply IHHred1|eapply IHHred2]; tea. eapply red_on_free_vars in Hred1; eauto. Qed. - + (* Lemma red_red_onctx {P Γ Δ Γ' s s' ctx} : untyped_subslet Γ s Δ -> onctx @@ -1468,13 +1468,13 @@ Section SubstitutionLemmas. len in r. now rewrite -app_context_assoc. Qed. *) - Ltac simpl_IHs := + Ltac simpl_IHs := repeat match goal with - | [ H : ?A -> ?B, H' : ?A |- _ ] => + | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H') end. - Lemma subst_inst_case_context_wf s k pars puinst ctx : + Lemma subst_inst_case_context_wf s k pars puinst ctx : test_context_k (fun k : nat => on_free_vars (closedP k xpredT)) #|pars| ctx -> subst_context s k (inst_case_context pars puinst ctx) = inst_case_context (map (subst s k) pars) puinst ctx. @@ -1485,12 +1485,12 @@ Section SubstitutionLemmas. apply map_ext => x. now rewrite subst_inst. Qed. - Lemma on_ctx_free_vars_snoc p Γ d : + Lemma on_ctx_free_vars_snoc p Γ d : on_ctx_free_vars (shiftnP 1 p) (Γ ,, d) = on_ctx_free_vars p Γ && on_free_vars_decl p d. Proof using Type. now rewrite (on_ctx_free_vars_concat _ _ [_]) on_ctx_free_vars_tip /= addnP_shiftnP. Qed. - + Lemma addnP_shiftnP_k k n p : addnP (k + n) (shiftnP k p) =1 addnP n p. Proof using Type. now rewrite Nat.add_comm -addnP_add addnP_shiftnP. @@ -1502,7 +1502,7 @@ Proof using Type. rewrite subst_context_app. lia_f_equal. Qed. - Lemma red_red {P Γ Δ Γ' s s' b} : + Lemma red_red {P Γ Δ Γ' s s' b} : on_ctx_free_vars P (Γ ,,, Δ ,,, Γ') -> on_free_vars P b -> All2 (red Σ Γ) s s' -> @@ -1517,10 +1517,10 @@ Qed. |- context [tRel _] => idtac | |- _ => cbn -[plus] end; try easy; - autorewrite with map; + autorewrite with map; rewrite ?Nat.add_assoc; try solve [f_equal; auto; solve_all]. - + - unfold subst. destruct (#|Γ'| <=? i) eqn:Heq. + destruct nth_error eqn:Heq'. @@ -1555,7 +1555,7 @@ Qed. rewrite subst_context_snoc Nat.add_0_r in X1. apply X1 => //. * rewrite /= on_ctx_free_vars_snoc onΓ /=; auto with fvs. * cbn. apply (All_impl ons) => ?; now rewrite (addnP_shiftnP_k 1). - + - apply red_app; eauto. - eapply (red_case (p:=(map_predicate_k id (subst s) #|Γ'| pred))); simpl; solve_all. * eapply All_All2; tea. solve_all. eapply b; eauto; solve_all. @@ -1565,7 +1565,7 @@ Qed. { rewrite test_context_k_closed_on_free_vars_ctx //. } rewrite -subst_context_inst_context -app_context_assoc -(subst_context_app' _ 0). relativize (_ + _); [eapply X2|]; tea; auto; len; solve_all. - { rewrite !app_context_assoc. + { rewrite !app_context_assoc. relativize #|pcontext pred|; [erewrite on_ctx_free_vars_extend|]; len => //. rewrite onΓ => /=. eapply on_free_vars_ctx_inst_case_context; trea; revgoals. @@ -1579,7 +1579,7 @@ Qed. { rewrite test_context_k_closed_on_free_vars_ctx //. apply X. } rewrite -subst_context_inst_context -app_context_assoc -(subst_context_app' _ 0). relativize (_ + _); [eapply X|]; tea; auto; len; solve_all. - { rewrite !app_context_assoc. + { rewrite !app_context_assoc. relativize #|bcontext x|; [erewrite on_ctx_free_vars_extend|]; len => //. rewrite onΓ => /=. eapply on_free_vars_ctx_inst_case_context; trea; solve_all. erewrite test_context_k_closed_on_free_vars_ctx; tea. apply X. } @@ -1608,7 +1608,7 @@ Qed. now len in b2. } now rewrite -Nat.add_assoc addnP_shiftnP_k. Qed. - + Lemma untyped_substitution_red {Γ Δ Γ' s M N} : untyped_subslet Γ s Δ -> on_ctx_free_vars (shiftnP #|Γ,,, Δ,,, Γ'| xpred0) (Γ ,,, Δ ,,, Γ') -> @@ -1671,17 +1671,17 @@ Qed. simpl in X. now apply X. Qed. - Lemma usubst_well_subst {Γ σ Δ} : + Lemma usubst_well_subst {Γ σ Δ} : usubst Γ σ Δ -> - (forall x decl, nth_error Γ x = Some decl -> + (forall x decl, nth_error Γ x = Some decl -> Σ ;;; Δ |- σ x : (decl.(decl_type)).[↑^(S x) ∘s σ]) -> well_subst Σ Γ σ Δ. Proof using Type. - intros us hty. split; eauto. + intros us hty. split; eauto. intros x decl hnth. specialize (hty x decl hnth). now sigma. Qed. - Lemma subslet_well_subst {Γ Γ' s Δ} : + Lemma subslet_well_subst {Γ Γ' s Δ} : subslet Σ Γ s Γ' -> wf_local Σ (Γ ,,, subst_context s 0 Δ) -> well_subst Σ (Γ ,,, Γ' ,,, Δ) (⇑^#|Δ| (s ⋅n ids)) (Γ ,,, subst_context s 0 Δ). @@ -1698,7 +1698,7 @@ Qed. - econstructor; auto. rewrite nth_error_app_lt; len => //. now rewrite nth_error_subst_context hnth. - - rewrite /subst_decl. simpl. + - rewrite /subst_decl. simpl. sigma. rewrite -shiftk_shift -subst_compose_assoc -shiftk_shift. (* rewrite lift0_inst !subst_inst_aux Nat.add_0_r. *) rewrite subst_shift_comm. @@ -1762,9 +1762,9 @@ Qed. * eapply (subslet_well_subst (Δ:=[])) in sub; rewrite ?subst_context_nil in sub |- *. + apply sub. - + pcuicfo. + + pcuicfo. Qed. -End SubstitutionLemmas. +End SubstitutionLemmas. Theorem substitution_prop {cf} : env_prop (fun Σ Γ0 t T => @@ -1861,7 +1861,7 @@ Proof. + eapply (isType_substitution Hs), wteq. + eapply (isType_substitution Hs), wteq. + move/wt_cumul_pb_equalityP: wteq; elim. - - intros t u cmp. + - intros t u cmp. constructor. now eapply subst_compare_term. - move=> t u v red cum. destruct le. diff --git a/pcuic/theories/PCUICTelescopes.v b/pcuic/theories/PCUICTelescopes.v index c5efbcfdb..c68fec41a 100644 --- a/pcuic/theories/PCUICTelescopes.v +++ b/pcuic/theories/PCUICTelescopes.v @@ -3,7 +3,7 @@ From Coq Require Import Utf8 CRelationClasses ProofIrrelevance. From MetaCoq.Template Require Import config Universes utils BasicAst. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICInduction - PCUICReflect PCUICLiftSubst PCUICSigmaCalculus + PCUICReflect PCUICLiftSubst PCUICSigmaCalculus PCUICUnivSubst PCUICTyping PCUICUnivSubstitutionConv PCUICUnivSubstitutionTyp PCUICCumulativity PCUICPosition PCUICEquality PCUICInversion PCUICCumulativity PCUICReduction @@ -14,7 +14,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICInduc PCUICClosed PCUICClosedTyp PCUICSubstitution PCUICContextSubst PCUICWellScopedCumulativity PCUICWeakeningConv PCUICWeakeningTyp PCUICGeneration PCUICUtils PCUICContexts - PCUICArities PCUICSpine. + PCUICArities PCUICSpine. Require Import Equations.Prop.DepElim. Require Import Equations.Type.Relation_Properties. @@ -34,4 +34,3 @@ Inductive tele_inst {cf:checker_flags} Σ (Γ : context) : list term -> telescop tele_inst Σ Γ s (Δ ,, vdef na t T). - \ No newline at end of file diff --git a/pcuic/theories/PCUICToTemplate.v b/pcuic/theories/PCUICToTemplate.v index 24901b2f9..ac315087b 100644 --- a/pcuic/theories/PCUICToTemplate.v +++ b/pcuic/theories/PCUICToTemplate.v @@ -10,7 +10,7 @@ Definition uint63_from_model (i : uint63_model) : Uint63.int := Definition float64_from_model (f : float64_model) : PrimFloat.float := FloatOps.SF2Prim (proj1_sig f). - + Definition trans_prim (t : prim_val) : Ast.term := match t.π2 with | primIntModel i => Ast.tInt i @@ -18,7 +18,7 @@ Definition trans_prim (t : prim_val) : Ast.term := end. Definition trans_predicate (t : PCUICAst.predicate Ast.term) : predicate Ast.term := - {| pparams := t.(PCUICAst.pparams); + {| pparams := t.(PCUICAst.pparams); puinst := t.(PCUICAst.puinst); pcontext := forget_types t.(PCUICAst.pcontext); preturn := t.(PCUICAst.preturn) |}. @@ -26,7 +26,7 @@ Definition trans_predicate (t : PCUICAst.predicate Ast.term) : predicate Ast.ter Definition trans_branch (t : PCUICAst.branch Ast.term) : branch Ast.term := {| bcontext := forget_types t.(PCUICAst.bcontext); bbody := t.(PCUICAst.bbody) |}. - + Fixpoint trans (t : PCUICAst.term) : Ast.term := match t with | PCUICAst.tRel n => tRel n @@ -59,17 +59,17 @@ Notation trans_decl := (map_decl trans). Definition trans_local Γ := List.map trans_decl Γ. Definition trans_constructor_body (d : PCUICEnvironment.constructor_body) := - {| cstr_name := d.(PCUICEnvironment.cstr_name); + {| cstr_name := d.(PCUICEnvironment.cstr_name); cstr_args := trans_local d.(PCUICEnvironment.cstr_args); - cstr_indices := map trans d.(PCUICEnvironment.cstr_indices); + cstr_indices := map trans d.(PCUICEnvironment.cstr_indices); cstr_type := trans d.(PCUICEnvironment.cstr_type); cstr_arity := d.(PCUICEnvironment.cstr_arity) |}. Definition trans_projection_body (d : PCUICEnvironment.projection_body) := - {| proj_name := d.(PCUICEnvironment.proj_name); + {| proj_name := d.(PCUICEnvironment.proj_name); proj_type := trans d.(PCUICEnvironment.proj_type); proj_relevance := d.(PCUICEnvironment.proj_relevance) |}. - + Definition trans_one_ind_body (d : PCUICEnvironment.one_inductive_body) := {| ind_name := d.(PCUICEnvironment.ind_name); ind_relevance := d.(PCUICEnvironment.ind_relevance); @@ -105,9 +105,9 @@ Definition trans_global_decls (d : PCUICEnvironment.global_declarations) : globa List.map (on_snd trans_global_decl) d. Definition trans_global_env (d : PCUICEnvironment.global_env) : global_env := - {| universes := d.(PCUICEnvironment.universes); + {| universes := d.(PCUICEnvironment.universes); declarations := trans_global_decls d.(PCUICEnvironment.declarations); retroknowledge := d.(PCUICEnvironment.retroknowledge) |}. - + Definition trans_global (Σ : PCUICEnvironment.global_env_ext) : global_env_ext := (trans_global_env (fst Σ), snd Σ). diff --git a/pcuic/theories/PCUICToTemplateCorrectness.v b/pcuic/theories/PCUICToTemplateCorrectness.v index 16594e653..98fc55334 100644 --- a/pcuic/theories/PCUICToTemplateCorrectness.v +++ b/pcuic/theories/PCUICToTemplateCorrectness.v @@ -3,7 +3,7 @@ From Coq Require Import ssreflect ssrbool Utf8 CRelationClasses. From Equations.Type Require Import Relation Relation_Properties. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction PCUICLiftSubst PCUICEquality PCUICReduction PCUICCasesContexts PCUICTactics - PCUICWeakeningConv PCUICWeakeningTyp PCUICUnivSubst PCUICTyping PCUICGlobalEnv + PCUICWeakeningConv PCUICWeakeningTyp PCUICUnivSubst PCUICTyping PCUICGlobalEnv PCUICClosedTyp PCUICGeneration PCUICConversion (* Needs transitivity of cumulativity *) PCUICValidity PCUICArities PCUICInversion PCUICInductiveInversion PCUICCases PCUICWellScopedCumulativity PCUICSpine PCUICSR @@ -23,17 +23,17 @@ Set Default Proof Using "Type*". Require Import Equations.Prop.DepElim. From Equations Require Import Equations. -(** Translation from PCUIC back to template-coq terms. +(** Translation from PCUIC back to template-coq terms. This translation is not direct due to two peculiarities of template-coq's syntax: - - applications are n-ary and not all terms are well-formed, so we have to + - applications are n-ary and not all terms are well-formed, so we have to use an induction on the size of derivations to transform the binary applications into n-ary ones. - - The representation of cases in template-coq is "compact" in the sense that - the predicate and branches contexts do not appear in the syntax of terms but can - be canonically rebuilt on-demand, as long as the environment has a declaration for the - inductive type. In contrast, PCUIC has these contexts explicitely present in terms, - so that the theory of reduction (confluence) and conversion do not need to rely on any + - The representation of cases in template-coq is "compact" in the sense that + the predicate and branches contexts do not appear in the syntax of terms but can + be canonically rebuilt on-demand, as long as the environment has a declaration for the + inductive type. In contrast, PCUIC has these contexts explicitely present in terms, + so that the theory of reduction (confluence) and conversion do not need to rely on any such well-formedness arguments about the global environment, considerably simplifying the theory: For example one couldn't do recursive calls on such "rebuilt" contexts using simple structural recursion, the new contexts having no structural relation to the terms at hand. @@ -44,7 +44,7 @@ From Equations Require Import Equations. that every one-step reduction in a PCUIC cumulativity derivation goes from a well-typed term to a well-typed term. We can hence prove that Template-Coq's `red1` reductions follow from the untyped PCUIC reduction when restricted to well-typed terms (which have many more invariants). - We actually just need the term to be reduced to be well-typed to show that the interpretation + We actually just need the term to be reduced to be well-typed to show that the interpretation preserves one-step reduction in [trans_red1}]. *) @@ -75,7 +75,7 @@ Proof. now rewrite /trans_local map_app. Qed. -Lemma forget_types_map_context {term term'} (f : term' -> term) ctx : +Lemma forget_types_map_context {term term'} (f : term' -> term) ctx : forget_types (map_context f ctx) = forget_types ctx. Proof. now rewrite /forget_types map_map_context. @@ -99,7 +99,7 @@ Proof. autorewrite with map. solve_all. rewrite /trans_branch /T.map_branch; cbn; f_equal. autorewrite with map; solve_all. - rewrite b. now rewrite forget_types_length map_context_length. + rewrite b. now rewrite forget_types_length map_context_length. - f_equal; auto; red in X; solve_list. - f_equal; auto; red in X; solve_list. - destruct p as [? []]; eauto. @@ -203,7 +203,7 @@ Lemma trans_mkApps t args: mkApps (trans t) (map trans args). Proof. induction args in t |- *. - - reflexivity. + - reflexivity. - cbn [map]. rewrite <- AstUtils.mkApps_mkApp. cbn. @@ -214,7 +214,7 @@ Qed. Lemma trans_decl_type decl: trans (decl_type decl) = decl_type (trans_decl decl). -Proof. +Proof. destruct decl. reflexivity. Qed. @@ -261,7 +261,7 @@ Proof. destruct x. unfold map_def. cbn in *. - now rewrite e e0. + now rewrite e e0. + apply IHX. - f_equal. rewrite map_length. @@ -273,7 +273,7 @@ Proof. destruct x. unfold map_def. cbn in *. - now rewrite e e0. + now rewrite e e0. + apply IHX. - destruct p as [? []]; eauto. Qed. @@ -292,7 +292,7 @@ Lemma trans_subst_instance u t: subst_instance u (trans t). Proof. induction t using PCUICInduction.term_forall_list_ind;cbn;auto;try congruence. - - do 2 rewrite map_map. + - do 2 rewrite map_map. f_equal. apply All_map_eq. apply X. @@ -302,7 +302,7 @@ Proof. cbn. reflexivity. - red in X, X0. - f_equal; solve_all. + f_equal; solve_all. + rewrite /trans_predicate /= /id /T.map_predicate /=. f_equal; solve_all. + rewrite /trans_branch; solve_all. @@ -331,7 +331,7 @@ Qed. Lemma trans_subst_instance_ctx Γ u : trans_local Γ@[u] = (trans_local Γ)@[u]. Proof. - rewrite /subst_instance /= /trans_local /SE.subst_instance_context /T.Env.subst_instance_context + rewrite /subst_instance /= /trans_local /SE.subst_instance_context /T.Env.subst_instance_context /map_context. rewrite !map_map_compose. apply map_ext. move => [na [b|] ty]; cbn; @@ -355,8 +355,8 @@ Qed. Lemma trans_type_of_constructor mdecl cdecl ind i u: trans (ST.type_of_constructor mdecl cdecl (ind, i) u) = - TT.type_of_constructor - (trans_minductive_body mdecl) + TT.type_of_constructor + (trans_minductive_body mdecl) (trans_constructor_body cdecl) (ind,i) u. @@ -401,7 +401,7 @@ Qed. Lemma trans_declared_projection Σ p mdecl idecl cdecl pdecl : S.declared_projection Σ.1 p mdecl idecl cdecl pdecl -> - T.declared_projection (trans_global Σ).1 p (trans_minductive_body mdecl) (trans_one_ind_body idecl) + T.declared_projection (trans_global Σ).1 p (trans_minductive_body mdecl) (trans_one_ind_body idecl) (trans_constructor_body cdecl) (trans_projection_body pdecl). Proof. intros []. split; [|split]. @@ -523,7 +523,7 @@ Proof. destruct t0 => //. apply decompose_app_rec_inv in da. simpl in da. subst t. rewrite trans_mkApps /=. - rewrite AstUtils.decompose_app_mkApps //. + rewrite AstUtils.decompose_app_mkApps //. Qed. Lemma refine_red1_r Σ Γ t u u' : u = u' -> TT.red1 Σ Γ t u -> TT.red1 Σ Γ t u'. @@ -562,7 +562,7 @@ Proof. - apply IHmfix. Qed. -Lemma trans_subst_context s k Γ : +Lemma trans_subst_context s k Γ : trans_local (SE.subst_context s k Γ) = T.Env.subst_context (map trans s) k (trans_local Γ). Proof. induction Γ as [|[na [b|] ty] Γ]; simpl; auto. @@ -574,7 +574,7 @@ Proof. now rewrite !trans_subst map_length. Qed. -Lemma trans_lift_context n k Γ : +Lemma trans_lift_context n k Γ : trans_local (SE.lift_context n k Γ) = T.Env.lift_context n k (trans_local Γ). Proof. induction Γ as [|[na [b|] ty] Γ]; simpl; auto. @@ -622,7 +622,7 @@ Proof. now rewrite /SE.expand_lets /SE.expand_lets_k trans_expand_lets_k. Qed. -Lemma alpha_eq_trans {Γ Δ} : +Lemma alpha_eq_trans {Γ Δ} : eq_context_upto_names Γ Δ -> All2 (TermEquality.compare_decls eq eq) (trans_local Γ) (trans_local Δ). Proof. @@ -642,7 +642,7 @@ Coercion isType_wt : isType >-> wt. Section wtsub. Context {cf} {Σ : PCUICEnvironment.global_env_ext} {wfΣ : PCUICTyping.wf Σ}. Import PCUICAst. - Definition wt_subterm Γ (t : term) : Type := + Definition wt_subterm Γ (t : term) : Type := let wt := wt Σ in match t with | tLambda na A B => wt Γ A × wt (Γ ,, vass na A) B @@ -651,7 +651,7 @@ Section wtsub. | tApp f a => wt Γ f × wt Γ a | tCase ci p c brs => All (wt Γ) p.(pparams) × - ∑ mdecl idecl, + ∑ mdecl idecl, [× declared_inductive Σ ci mdecl idecl, ci.(ci_npar) = mdecl.(ind_npars), consistent_instance_ext Σ (PCUICEnvironment.ind_universes mdecl) (PCUICAst.puinst p), @@ -662,16 +662,16 @@ Section wtsub. (PCUICEnvironment.smash_context [] (PCUICEnvironment.ind_params mdecl)@[PCUICAst.puinst p]), wt (Γ ,,, PCUICCases.case_predicate_context ci mdecl idecl p) p.(preturn), wt Γ c & - All2i (fun i cdecl br => + All2i (fun i cdecl br => [× wf_branch cdecl br, All2 (PCUICEquality.compare_decls eq eq) (bcontext br) (PCUICCases.cstr_branch_context ci mdecl cdecl), wf_local_rel Σ (Γ ,,, smash_context [] (ind_params mdecl)@[p.(puinst)]) br.(bcontext)@[p.(puinst)], - All2 (PCUICEquality.compare_decls eq eq) + All2 (PCUICEquality.compare_decls eq eq) (Γ ,,, PCUICCases.case_branch_context ci mdecl p (forget_types br.(bcontext)) cdecl) (Γ ,,, inst_case_branch_context p br) & wt (Γ ,,, PCUICCases.case_branch_context ci mdecl p (forget_types br.(bcontext)) cdecl) br.(bbody)]) 0 idecl.(ind_ctors) brs] | tProj p c => wt Γ c - | tFix mfix idx | tCoFix mfix idx => + | tFix mfix idx | tCoFix mfix idx => All (fun d => wt Γ d.(dtype) × wt (Γ ,,, fix_context mfix) d.(dbody)) mfix | tEvar _ l => False | _ => unit @@ -752,7 +752,7 @@ Ltac outtimes := Lemma red1_cumul {cf} (Σ : global_env_ext) pb Γ T U : TT.red1 Σ Γ T U -> TT.cumul_gen Σ Γ pb T U. Proof. intros r. - econstructor 2; tea. constructor. + econstructor 2; tea. constructor. destruct pb. - apply TermEquality.eq_term_refl. - apply TermEquality.leq_term_refl. @@ -767,25 +767,25 @@ Proof. - eapply TermEquality.leq_term_refl. Qed. -Definition TTconv {cf} (Σ : global_env_ext) Γ : relation term := +Definition TTconv {cf} (Σ : global_env_ext) Γ : relation term := clos_refl_sym_trans (relation_disjunction (TT.red1 Σ Γ) (TermEquality.eq_term Σ (T.global_ext_constraints Σ))). Lemma red1_conv {cf} (Σ : global_env_ext) Γ T U : TT.red1 Σ Γ T U -> TTconv Σ Γ T U. Proof. intros r. - now repeat constructor. + now repeat constructor. Qed. -Lemma trans_expand_lets_ctx Γ Δ : +Lemma trans_expand_lets_ctx Γ Δ : trans_local (SE.expand_lets_ctx Γ Δ) = expand_lets_ctx (trans_local Γ) (trans_local Δ). Proof. rewrite /SE.expand_lets_ctx /SE.expand_lets_k_ctx /expand_lets_ctx /expand_lets_k_ctx. now rewrite !trans_subst_context trans_extended_subst trans_lift_context - context_assumptions_map map_length. + context_assumptions_map map_length. Qed. -Lemma trans_inds ind u mdecl : - map trans (PCUICAst.inds (inductive_mind ind) u (SE.ind_bodies mdecl)) = +Lemma trans_inds ind u mdecl : + map trans (PCUICAst.inds (inductive_mind ind) u (SE.ind_bodies mdecl)) = inds (inductive_mind ind) u (ind_bodies (trans_minductive_body mdecl)). Proof. rewrite PCUICCases.inds_spec inds_spec. @@ -794,7 +794,7 @@ Proof. Qed. Lemma trans_cstr_branch_context ci mdecl cdecl : - trans_local (PCUICCases.cstr_branch_context ci mdecl cdecl) = + trans_local (PCUICCases.cstr_branch_context ci mdecl cdecl) = cstr_branch_context ci (trans_minductive_body mdecl) (trans_constructor_body cdecl). Proof. rewrite /PCUICCases.cstr_branch_context /cstr_branch_context. @@ -803,7 +803,7 @@ Proof. Qed. Lemma trans_cstr_branch_context_inst ci mdecl cdecl i : - trans_local (PCUICCases.cstr_branch_context ci mdecl cdecl)@[i] = + trans_local (PCUICCases.cstr_branch_context ci mdecl cdecl)@[i] = (cstr_branch_context ci (trans_minductive_body mdecl) (trans_constructor_body cdecl))@[i]. Proof. now rewrite trans_subst_instance_ctx trans_cstr_branch_context. @@ -823,7 +823,7 @@ Qed. Notation eq_names := (All2 (fun x y => x = (decl_name y))). -Lemma eq_names_subst_context nas Γ s k : +Lemma eq_names_subst_context nas Γ s k : eq_names nas Γ -> eq_names nas (subst_context s k Γ). Proof. @@ -832,7 +832,7 @@ Proof. * rewrite subst_context_snoc. constructor; auto. Qed. -Lemma eq_names_subst_instance nas Γ u : +Lemma eq_names_subst_instance nas Γ u : eq_names nas Γ -> eq_names nas (subst_instance u Γ). Proof. @@ -898,11 +898,11 @@ Proof. rewrite context_assumptions_map2_set_binder_name. len. rewrite !lengths. eapply (Forall2_length Hforall). - now do 3 rewrite !context_assumptions_subst_context ?context_assumptions_lift_context ?context_assumptions_subst_instance + now do 3 rewrite !context_assumptions_subst_context ?context_assumptions_lift_context ?context_assumptions_subst_instance /cstr_branch_context /expand_lets_ctx /expand_lets_k_ctx. Qed. -Lemma cstr_branch_context_assumptions ci mdecl cdecl : +Lemma cstr_branch_context_assumptions ci mdecl cdecl : SE.context_assumptions (PCUICCases.cstr_branch_context ci mdecl cdecl) = SE.context_assumptions (SE.cstr_args cdecl). Proof. @@ -913,7 +913,7 @@ Qed. #[global] Instance compare_decls_refl : Reflexive (TermEquality.compare_decls eq eq). -Proof. +Proof. intros [na [b|] ty]; constructor; auto. Qed. @@ -937,7 +937,7 @@ Proof. intros d d' d'' [] H; depelim H; subst; constructor; auto; now etransitivity. Qed. -Lemma trans_reln l p Γ : map trans (SE.reln l p Γ) = +Lemma trans_reln l p Γ : map trans (SE.reln l p Γ) = reln (map trans l) p (trans_local Γ). Proof. induction Γ as [|[na [b|] ty] Γ] in l, p |- *; simpl; auto. @@ -950,7 +950,7 @@ Proof. Qed. Lemma trans_ind_predicate_context ci mdecl idecl : - trans_local (PCUICCases.ind_predicate_context ci mdecl idecl) = + trans_local (PCUICCases.ind_predicate_context ci mdecl idecl) = (Ast.ind_predicate_context ci (trans_minductive_body mdecl) (trans_one_ind_body idecl)). Proof. @@ -967,7 +967,7 @@ Qed. Lemma trans_ind_predicate_context_eq p ci mdecl idecl : eq_context_upto_names (PCUICAst.pcontext p) - (PCUICCases.ind_predicate_context ci mdecl idecl) -> + (PCUICCases.ind_predicate_context ci mdecl idecl) -> All2 (λ (x : binder_annot name) (y : Env.context_decl), eq_binder_annot x (decl_name y)) @@ -982,7 +982,7 @@ Proof. Qed. Lemma trans_cstr_branch_context_eq ci mdecl cdecl br : - eq_context_upto_names (PCUICAst.bcontext br) + eq_context_upto_names (PCUICAst.bcontext br) (PCUICCases.cstr_branch_context ci mdecl cdecl) -> All2 (λ (x : binder_annot name) (y : Env.context_decl), @@ -1009,7 +1009,7 @@ Proof. destruct X as [? []]. red in X0. econstructor; cbn; eauto; tea. eapply trans_declared_inductive in d; tea. now cbn. cbn. eapply trans_ind_predicate_context_eq => //. now symmetry. - rewrite map_length. cbn. rewrite context_assumptions_map //. + rewrite map_length. cbn. rewrite context_assumptions_map //. destruct w. now rewrite -(declared_minductive_ind_npars (proj1 d)). cbn. solve_all. eapply All2_map, All2_map_right. solve_all. eapply All2i_All2; tea. cbv beta. @@ -1024,7 +1024,7 @@ Qed. #[global] Hint Resolve trans_wf : wf. -Lemma red1_alpha_eq Σ Γ Δ T U : +Lemma red1_alpha_eq Σ Γ Δ T U : TT.red1 Σ Γ T U -> All2 (TermEquality.compare_decls eq eq) Γ Δ -> TT.red1 Σ Δ T U. @@ -1096,7 +1096,7 @@ Proof. cbn. intros x y H. destruct y; apply H. Qed. -Lemma trans_local_set_binder nas Γ : +Lemma trans_local_set_binder nas Γ : trans_local (map2 PCUICEnvironment.set_binder_name nas Γ) = map2 set_binder_name nas (trans_local Γ). Proof. @@ -1143,15 +1143,15 @@ Proof. Qed. Lemma trans_case_predicate_context {cf} {Σ : PCUICEnvironment.global_env_ext} - {wfΣ : PCUICTyping.wf Σ} Γ ci mdecl idecl p : + {wfΣ : PCUICTyping.wf Σ} Γ ci mdecl idecl p : S.declared_inductive Σ ci mdecl idecl -> - S.consistent_instance_ext Σ (PCUICEnvironment.ind_universes mdecl) (PCUICAst.puinst p) → + S.consistent_instance_ext Σ (PCUICEnvironment.ind_universes mdecl) (PCUICAst.puinst p) → let parctx := (PCUICEnvironment.ind_params mdecl)@[PCUICAst.puinst p] in PCUICSpine.spine_subst Σ Γ (PCUICAst.pparams p) (List.rev (PCUICAst.pparams p)) (PCUICEnvironment.smash_context [] parctx) -> wf_predicate mdecl idecl p -> - let p' := trans_predicate (PCUICAst.map_predicate id trans trans trans_local p) in + let p' := trans_predicate (PCUICAst.map_predicate id trans trans trans_local p) in (case_predicate_context ci (trans_minductive_body mdecl) (trans_one_ind_body idecl) p') = (trans_local (PCUICCases.case_predicate_context ci mdecl idecl p)). Proof. @@ -1164,14 +1164,14 @@ Proof. rewrite /pre_case_predicate_context_gen /inst_case_context. rewrite /PCUICCases.pre_case_predicate_context_gen /PCUICCases.inst_case_context. rewrite [map _ _]trans_subst_context map_rev. f_equal. - rewrite trans_subst_instance_ctx. + rewrite trans_subst_instance_ctx. now rewrite trans_ind_predicate_context. Qed. -Lemma OnOne2All2i_OnOne2All {A B : Type} (l1 l2 : list A) (l3 : list B) +Lemma OnOne2All2i_OnOne2All {A B : Type} (l1 l2 : list A) (l3 : list B) (R1 : A → A → Type) (R2 : nat → B → A → Type) (n : nat) (R3 : B -> A -> A -> Type) : - OnOne2 R1 l1 l2 → - All2i R2 n l3 l1 → + OnOne2 R1 l1 l2 → + All2i R2 n l3 l1 → (forall (n0 : nat) (x y : A) (z : B), R1 x y → R2 n0 z x → R3 z x y) → OnOne2All R3 l3 l1 l2. Proof. induction 1 in n, l3 |- *; intros H; depelim H. @@ -1192,7 +1192,7 @@ Proof. eapply map_ext. intros []; reflexivity. Qed. -Lemma trans_bcontext br : +Lemma trans_bcontext br : (bcontext (trans_branch (PCUICAst.map_branch trans (map_context trans) br))) = forget_types (PCUICAst.bcontext br). Proof. cbn. now rewrite map_context_trans map_map_compose. @@ -1202,7 +1202,7 @@ Lemma OnOne2All_map2_map_all {A B I I'} {P} {i : list I} {l l' : list A} (g : B OnOne2All (fun i x y => P (g (f x) i) (f x) (f y)) i l l' -> OnOne2All P (map2 g (map f l) i) (map f l) (map f l'). Proof. induction 1; simpl; constructor; try congruence. len. - now rewrite map2_length !map_length. + now rewrite map2_length !map_length. Qed. Lemma trans_red1 {cf} (Σ : PCUICEnvironment.global_env_ext) {wfΣ : PCUICTyping.wf Σ} Γ T U : @@ -1211,15 +1211,15 @@ Lemma trans_red1 {cf} (Σ : PCUICEnvironment.global_env_ext) {wfΣ : PCUICTyping TT.red1 (trans_global Σ) (trans_local Γ) (trans T) (trans U). Proof. induction 1 using red1_ind_all; simpl in *; intros wt; - match goal with + match goal with | |- context [tCase _ _ _ _] => idtac | _ => eapply wt_inv in wt; tea; cbn in wt; repeat outtimes end; try solve [econstructor; eauto]. - - - simpl. + + - simpl. rewrite trans_subst; auto. constructor. - + - rewrite trans_subst; eauto. repeat constructor. - rewrite trans_lift; eauto. repeat constructor. rewrite nth_error_map. @@ -1263,12 +1263,12 @@ Proof. pose proof (nth_error_Some_length hnth). destruct args. simpl. elimtype False; cbn in H1. lia. cbn -[mkApps]. - eapply TT.red_fix. + eapply TT.red_fix. apply trans_unfold_fix; eauto. eapply (trans_is_constructor (t0 :: args)). now rewrite /is_constructor hnth. discriminate. - + - rewrite trans_mkApps. rewrite !trans_mkApps; eauto with wf. apply trans_unfold_cofix in H; eauto with wf. @@ -1277,14 +1277,14 @@ Proof. - rewrite !trans_mkApps. apply trans_unfold_cofix in H; eauto with wf. eapply TT.red_cofix_proj; eauto. - + - rewrite trans_subst_instance. econstructor. apply (trans_declared_constant _ c decl H). destruct decl. now simpl in *; subst cst_body0. - rewrite trans_mkApps; eauto with wf. simpl. constructor; now rewrite nth_error_map H. - + - destruct wt as []; constructor; auto. - destruct wt as []; constructor; auto. - destruct wt as []; constructor; auto. @@ -1303,7 +1303,7 @@ Proof. rewrite /inst_case_context. apply compare_decls_conv. eapply All2_app. 2:{ reflexivity. } - eapply compare_decls_eq_context. + eapply compare_decls_eq_context. apply (PCUICAlpha.inst_case_predicate_context_eq (ind:=ci) w). cbn. apply compare_decls_eq_context. now symmetry. } rewrite [trans_local _]map_app. @@ -1317,7 +1317,7 @@ Proof. - eapply wt_inv in wt as [hpars [mdecl [idecl []]]]. econstructor; eauto. - + - eapply wt_inv in wt as [hpars [mdecl [idecl []]]]. econstructor; eauto. eapply trans_declared_inductive; tea. @@ -1341,8 +1341,8 @@ Proof. * eapply trans_wf; tea. * repeat constructor. eapply trans_wf; tea. * constructor; auto. - - - constructor. + + - constructor. eapply OnOne2_All_mix_left in X; tea. apply OnOne2_map. solve_all. red; intuition auto. destruct x, y; simpl in *. noconf b0. @@ -1356,8 +1356,8 @@ Proof. now rewrite /trans_local map_app in X. destruct x, y; simpl in *. noconf b0. reflexivity. - - - constructor. + + - constructor. eapply OnOne2_All_mix_left in X; tea. apply OnOne2_map. solve_all. red; intuition auto. destruct x, y; simpl in *. noconf b0. @@ -1394,7 +1394,7 @@ Proof. destruct nth_error => /= //. rewrite nth_error_map. destruct nth_error => /= //. -Qed. +Qed. Lemma trans_eq_context_gen_eq_binder_annot Γ Δ : eq_context_gen eq eq Γ Δ -> @@ -1447,7 +1447,7 @@ From MetaCoq.PCUIC Require Import PCUICCumulativity. Section wtcumul. Import PCUICAst PCUICTyping PCUICEquality. - Record wt_red1 {cf} (Σ : PCUICEnvironment.global_env_ext) (Γ : PCUICEnvironment.context) T U := + Record wt_red1 {cf} (Σ : PCUICEnvironment.global_env_ext) (Γ : PCUICEnvironment.context) T U := { wt_red1_red1 : PCUICReduction.red1 Σ Γ T U; wt_red1_dom : isType Σ Γ T; wt_red1_codom : isType Σ Γ U }. @@ -1459,14 +1459,14 @@ Section wtcumul. | wt_cumul_red_l t u v : wt_red1 Σ Γ t v -> Σ ;;; Γ |-- v <= u -> Σ ;;; Γ |-- t <= u | wt_cumul_red_r t u v : Σ ;;; Γ |-- t <= v -> wt_red1 Σ Γ u v -> Σ ;;; Γ |-- t <= u where " Σ ;;; Γ |-- t <= u " := (wt_cumul Σ Γ t u) : type_scope. - + Lemma cumul_decorate {cf} (Σ : global_env_ext) {wfΣ : wf Σ} Γ T U : isType Σ Γ T -> isType Σ Γ U -> cumulAlgo Σ Γ T U -> wt_cumul Σ Γ T U. Proof. intros ht hu. - induction 1. + induction 1. - constructor. auto. - pose proof (isType_red1 ht r). econstructor 2. @@ -1482,7 +1482,7 @@ Lemma trans_cumul {cf} {Σ : PCUICEnvironment.global_env_ext} {Γ T U} {wfΣ : P wt_cumul Σ Γ T U -> TT.cumul_gen (trans_global Σ) (trans_local Γ) Cumul (trans T) (trans U). Proof. - induction 1. + induction 1. - constructor; auto. eapply trans_leq_term in c. now rewrite -trans_global_ext_constraints. @@ -1603,8 +1603,8 @@ Lemma trans_mfix_All2 {cf} Σ Γ mfix xfix: All (fun d : def term => TT.typing (trans_global Σ) - (trans_local Γ ,,, TT.fix_context (map (map_def trans trans) xfix)) - (dbody d) (T.lift0 #|TT.fix_context (map (map_def trans trans) xfix)| (dtype d))) + (trans_local Γ ,,, TT.fix_context (map (map_def trans trans) xfix)) + (dbody d) (T.lift0 #|TT.fix_context (map (map_def trans trans) xfix)| (dtype d))) (map (map_def trans trans) mfix). Proof. induction 1. @@ -1685,11 +1685,11 @@ Lemma trans_destInd t : ST.destInd t = TT.destInd (trans t). Proof. destruct t => //. simpl. now destruct (mkApp_ex (trans t1) (trans t2)) as [f [u ->]]. - now destruct prim as [? []]. + now destruct prim as [? []]. Qed. -Lemma trans_decompose_app t : - let '(hd, args) := decompose_app t in +Lemma trans_decompose_app t : + let '(hd, args) := decompose_app t in AstUtils.decompose_app (trans t) = (trans hd, map trans args). Proof. destruct (decompose_app t) eqn:da. @@ -1740,7 +1740,7 @@ Proof. Qed. Lemma map_option_out_check_one_fix mfix : - map (fun x => TT.check_one_fix (map_def trans trans x)) mfix = + map (fun x => TT.check_one_fix (map_def trans trans x)) mfix = map ST.check_one_fix mfix. Proof. eapply map_ext => x. apply trans_check_one_fix. @@ -1759,7 +1759,7 @@ Proof. Qed. Lemma map_option_out_check_one_cofix mfix : - map (fun x => TT.check_one_cofix (map_def trans trans x)) mfix = + map (fun x => TT.check_one_cofix (map_def trans trans x)) mfix = map ST.check_one_cofix mfix. Proof. eapply map_ext => x. apply trans_check_one_cofix. @@ -1774,7 +1774,7 @@ Proof. Qed. Lemma trans_wf_fixpoint Σ mfix : - TT.wf_fixpoint (trans_global_env Σ) (map (map_def trans trans) mfix) = + TT.wf_fixpoint (trans_global_env Σ) (map (map_def trans trans) mfix) = ST.wf_fixpoint Σ mfix. Proof. unfold ST.wf_fixpoint, ST.wf_fixpoint_gen, TT.wf_fixpoint. @@ -1788,7 +1788,7 @@ Proof. Qed. Lemma trans_wf_cofixpoint Σ mfix : - TT.wf_cofixpoint (trans_global_env Σ) (map (map_def trans trans) mfix) = + TT.wf_cofixpoint (trans_global_env Σ) (map (map_def trans trans) mfix) = ST.wf_cofixpoint Σ mfix. Proof. unfold ST.wf_cofixpoint, ST.wf_cofixpoint_gen, TT.wf_cofixpoint. @@ -1823,8 +1823,8 @@ Axiom cofix_guard_trans : ST.cofix_guard Σ Γ mfix -> TT.cofix_guard (trans_global Σ) (trans_local Γ) (map (map_def trans trans) mfix). -(* This version of typing spine allows to not require [isType] assumptions at the end of the - application chain, which is crucial to be able to build a spine that both encompasses PCUIC's +(* This version of typing spine allows to not require [isType] assumptions at the end of the + application chain, which is crucial to be able to build a spine that both encompasses PCUIC's applications and mimicks the typing rule of Template. Otherwise we would only model: |- tProd na A B : s @@ -1838,12 +1838,12 @@ Axiom cofix_guard_trans : following from confluence. In the end a typing derivation for an application that can mix application and cumulativity steps at any - point: + point: tApp (tApp f u) v : T' can be translated to typing_spine fty [u; v] T' -*) +*) Import PCUICAst PCUICLiftSubst PCUICTyping. Inductive typing_spine {cf} (Σ : global_env_ext) (Γ : context) : term -> list term -> term -> Type := @@ -1894,17 +1894,17 @@ Proof. Defined. (* The size includes the new [isType] hypothesis *) -Lemma typing_spine_weaken_concl_size {cf:checker_flags} {Σ Γ T args S S'} - (wf : wf Σ.1) +Lemma typing_spine_weaken_concl_size {cf:checker_flags} {Σ Γ T args S S'} + (wf : wf Σ.1) (sp :typing_spine Σ Γ T args S) (tyT : isType Σ Γ T) (Hs : Σ ;;; Γ ⊢ S ≤ S') (ist : isType Σ Γ S') : - typing_spine_size (typing_spine_weaken_concl sp tyT Hs ist) <= + typing_spine_size (typing_spine_weaken_concl sp tyT Hs ist) <= max (typing_spine_size sp) (typing_size ist.π2). Proof. induction sp; simpl; auto. lia. - rewrite - !Nat.max_assoc. + rewrite - !Nat.max_assoc. specialize (IHsp (PCUICArities.isType_apply i t) Hs). lia. Qed. @@ -1915,11 +1915,11 @@ Ltac sig := unshelve eexists. The invariant is witnessed by the spine size being lower than the arguments. *) Lemma typing_spine_app {cf:checker_flags} Σ Γ ty args na A B arg - (wf : wf Σ.1) + (wf : wf Σ.1) (isty : isType Σ Γ (tProd na A B)) (sp : typing_spine Σ Γ ty args (tProd na A B)) - (argd : Σ ;;; Γ |- arg : A) : - ∑ sp' : typing_spine Σ Γ ty (args ++ [arg]) (B {0 := arg}), + (argd : Σ ;;; Γ |- arg : A) : + ∑ sp' : typing_spine Σ Γ ty (args ++ [arg]) (B {0 := arg}), typing_spine_size sp' <= max (typing_size isty.π2) (max (typing_spine_size sp) (typing_size argd)). Proof. revert arg argd. @@ -1930,7 +1930,7 @@ Proof. constructor. * simpl. lia. - intros arg Harg. simpl. - sig. + sig. * econstructor; eauto. constructor. * simpl. lia. - intros arg Harg. simpl. @@ -1960,17 +1960,17 @@ Proof. eapply IHtyping_spine. now rewrite eq. exact eq. apply Harg. apply X. Defined. -(** This is the central lemma for this translation: - any PCUIC typing of an application `t` can be decomposed as - a typing of the head of `t` followed by a typing spine for +(** This is the central lemma for this translation: + any PCUIC typing of an application `t` can be decomposed as + a typing of the head of `t` followed by a typing spine for its arguments `l`. *) Lemma type_app {cf} {Σ Γ t T} (d : Σ ;;; Γ |- t : T) : wf Σ.1 -> - if isApp t then - let (f, l) := decompose_app t in - ∑ fty (d' : Σ ;;; Γ |- f : fty), - ((typing_size d' <= typing_size d) * + if isApp t then + let (f, l) := decompose_app t in + ∑ fty (d' : Σ ;;; Γ |- f : fty), + ((typing_size d' <= typing_size d) * ∑ (sp : typing_spine Σ Γ fty l T), (typing_spine_size sp <= typing_size d))%type else True. @@ -2019,16 +2019,16 @@ Qed. of the translation to any of the typing derivations in the spine, then we can produce a typing spine in the n-ary application template-coq spec. - We have two cases to consider at the "end" of the spine: either we have the same translation of the + We have two cases to consider at the "end" of the spine: either we have the same translation of the PCUIC conclusion type, or there is exactly one cumulativity step to get to this type. *) -Lemma make_typing_spine {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ fty l T} - (sp : PCUICToTemplateCorrectness.typing_spine Σ Γ fty l T) n - (IH : forall t' T' (Ht' : Σ ;;; Γ |- t' : T'), - typing_size Ht' <= n -> +Lemma make_typing_spine {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ fty l T} + (sp : PCUICToTemplateCorrectness.typing_spine Σ Γ fty l T) n + (IH : forall t' T' (Ht' : Σ ;;; Γ |- t' : T'), + typing_size Ht' <= n -> TT.typing (trans_global Σ) (trans_local Γ) (trans t') (trans T')) : isType Σ Γ fty -> typing_spine_size sp <= n -> - ∑ T', TT.typing_spine (trans_global Σ) (trans_local Γ) (trans fty) (map trans l) T' * + ∑ T', TT.typing_spine (trans_global Σ) (trans_local Γ) (trans fty) (map trans l) T' * ((T' = trans T) + (TT.cumul_gen (trans_global Σ) (trans_local Γ) Cumul T' (trans T) * ∑ s, TT.typing (trans_global Σ) (trans_local Γ) (trans T) (T.tSort s)))%type. @@ -2073,7 +2073,7 @@ Lemma it_mkLambda_or_LetIn_app l l' t : T.Env.it_mkLambda_or_LetIn (l ++ l') t = T.Env.it_mkLambda_or_LetIn l' (T.Env.it_mkLambda_or_LetIn l t). Proof. induction l in l', t |- *; simpl; auto. Qed. -Lemma trans_it_mkLambda_or_LetIn Γ T : +Lemma trans_it_mkLambda_or_LetIn Γ T : trans (it_mkLambda_or_LetIn Γ T) = T.Env.it_mkLambda_or_LetIn (trans_local Γ) (trans T). Proof. induction Γ using rev_ind. @@ -2083,8 +2083,8 @@ Proof. destruct x as [na [b|] ty] => /=; cbn; now f_equal. Qed. -Lemma All2i_All2_mapi {A B C D} P (f : nat -> A -> B) (g : nat -> C -> D) l l' : - All2i (fun i x y => P (f i x) (g i y)) 0 l l' -> +Lemma All2i_All2_mapi {A B C D} P (f : nat -> A -> B) (g : nat -> C -> D) l l' : + All2i (fun i x y => P (f i x) (g i y)) 0 l l' -> All2 P (mapi f l) (mapi g l'). Proof. rewrite /mapi. generalize 0. @@ -2098,7 +2098,7 @@ Proof. induction 1; constructor; auto. Qed. -Lemma eq_names_subst_context_pcuic nas Γ s k : +Lemma eq_names_subst_context_pcuic nas Γ s k : eq_names nas Γ -> eq_names nas (subst_context s k Γ). Proof. @@ -2107,7 +2107,7 @@ Proof. * rewrite subst_context_snoc. constructor; auto. Qed. -Lemma eq_names_subst_instance_pcuic nas (Γ : context) u : +Lemma eq_names_subst_instance_pcuic nas (Γ : context) u : eq_names nas Γ -> eq_names nas (subst_instance u Γ). Proof. @@ -2140,12 +2140,12 @@ Proof. - rewrite [Ast.case_branch_context_gen _ _ _ _ _ _]trans_inst_case_branch_context => //. f_equal. rewrite /case_branch_context. - symmetry. + symmetry. erewrite <- PCUICCasesContexts.inst_case_branch_context_eq => //. - rewrite trans_mkApps !lengths. rewrite trans_lift /ptm trans_it_mkLambda_or_LetIn. f_equal. rewrite !map_app (map_map_compose _ _ _ _ trans). f_equal. - setoid_rewrite trans_subst. + setoid_rewrite trans_subst. rewrite -(map_map_compose _ _ _ trans) map_rev. f_equal. rewrite (map_map_compose _ _ _ _ trans). setoid_rewrite trans_expand_lets_k. @@ -2175,10 +2175,10 @@ Lemma subst_telescope_subst_context s k Γ : Proof. rewrite /Env.subst_telescope Env.subst_context_alt. rewrite rev_mapi. apply mapi_rec_ext. - intros n [na [b|] ty] le le'; rewrite /= /Env.subst_decl /map_decl /=; - rewrite List.rev_length Nat.add_0_r in le'; + intros n [na [b|] ty] le le'; rewrite /= /Env.subst_decl /map_decl /=; + rewrite List.rev_length Nat.add_0_r in le'; f_equal. f_equal. f_equal. lia. f_equal; lia. - f_equal; lia. + f_equal; lia. Qed. Theorem pcuic_to_template {cf} (Σ : SE.global_env_ext) Γ t T : @@ -2188,12 +2188,12 @@ Theorem pcuic_to_template {cf} (Σ : SE.global_env_ext) Γ t T : Proof. intros X X0. revert Σ X Γ t T X0. - (** We use an induction principle allowing to apply induction to any subderivation of + (** We use an induction principle allowing to apply induction to any subderivation of functions in applications. *) apply (typing_ind_env_app_size (fun Σ Γ t T => TT.typing (trans_global Σ) (trans_local Γ) (trans t) (trans T) )%type - (fun Σ Γ => + (fun Σ Γ => TT.All_local_env (TT.lift_typing TT.typing (trans_global Σ)) (trans_local Γ)) );intros. - now eapply trans_wf_local_env, All_over_All. @@ -2220,7 +2220,7 @@ Proof. apply decompose_app_notApp in da. apply trans_isApp in da. eapply type_mkApps_napp. rewrite da //. - eassumption. + eassumption. eapply TT_typing_spine_app. simpl in X1. eapply X0. apply IH. apply TT.cumul_refl'. apply X4. @@ -2231,7 +2231,7 @@ Proof. apply decompose_app_notApp in da. apply trans_isApp in da. eapply type_mkApps_napp. rewrite da //. - eassumption. + eassumption. eapply TT_typing_spine_app. simpl in X0. eapply X0. apply IH. apply hcum. apply X4. @@ -2252,10 +2252,10 @@ Proof. + now apply trans_consistent_instance_ext. - rewrite trans_type_of_constructor. eapply TT.type_Construct; auto. - + destruct isdecl. + + destruct isdecl. constructor. - * now apply trans_declared_inductive. - * now apply map_nth_error. + * now apply trans_declared_inductive. + * now apply map_nth_error. - rewrite trans_mkApps map_app. simpl. rewrite /ptm trans_it_mkLambda_or_LetIn. @@ -2280,12 +2280,12 @@ Proof. clear. unfold app_context. change subst_instance_context with SE.subst_instance_context. unfold context. rewrite -map_rev. set (ctx := map _ (List.rev _)). clearbody ctx. intro HH; pose proof (ctx_inst_impl _ (fun _ _ _ _ => TT.typing _ _ _ _ ) _ _ _ _ HH (fun _ _ H => H.2)); revert X; clear HH. - now move: ctx; induction 1; cbn; constructor; auto; - rewrite -(List.rev_involutive (map trans_decl Δ)) subst_telescope_subst_context -map_rev + now move: ctx; induction 1; cbn; constructor; auto; + rewrite -(List.rev_involutive (map trans_decl Δ)) subst_telescope_subst_context -map_rev -(trans_subst_context [_]) -map_rev -PCUICSpine.subst_telescope_subst_context List.rev_involutive. + cbn [Ast.pparams Ast.pcontext trans_predicate]. rewrite (trans_case_predicate_context Γ); tea. - now rewrite -trans_local_app. + now rewrite -trans_local_app. + rewrite <- trans_global_ext_constraints. eassumption. + now rewrite trans_mkApps map_app in X7. @@ -2313,11 +2313,11 @@ Proof. + now apply trans_declared_projection. + rewrite trans_mkApps in X2. assumption. - + rewrite map_length H. now destruct mdecl. + + rewrite map_length H. now destruct mdecl. - rewrite trans_dtype. simpl. eapply TT.type_Fix; auto. + now rewrite fix_guard_trans. - + erewrite map_nth_error. + + erewrite map_nth_error. 2: apply H0. destruct decl. unfold map_def. @@ -2330,11 +2330,11 @@ Proof. + fold trans. subst types. eapply trans_mfix_All2; eassumption. - + now rewrite trans_wf_fixpoint. + + now rewrite trans_wf_fixpoint. - rewrite trans_dtype. simpl. eapply TT.type_CoFix; auto. + now eapply cofix_guard_trans. - + erewrite map_nth_error. + + erewrite map_nth_error. 2: eassumption. destruct decl. unfold map_def. diff --git a/pcuic/theories/PCUICTransform.v b/pcuic/theories/PCUICTransform.v index 9b5e35ba2..9951710f8 100644 --- a/pcuic/theories/PCUICTransform.v +++ b/pcuic/theories/PCUICTransform.v @@ -1,6 +1,6 @@ (** * Definition of programs in template-coq, well-typed terms and provided transformations **) From Coq Require Import ssreflect. -From MetaCoq.Template Require Import utils config Transform. +From MetaCoq.Template Require Import utils config Transform. From MetaCoq.Template Require TemplateProgram. Import TemplateProgram (template_program, wt_template_program, eval_template_program). @@ -8,16 +8,16 @@ From MetaCoq.PCUIC Require Import PCUICAstUtils PCUICAst TemplateToPCUIC PCUICGlobalEnv PCUICTyping PCUICEtaExpand PCUICProgram. From MetaCoq.PCUIC Require TemplateToPCUICWcbvEval - TemplateToPCUICCorrectness + TemplateToPCUICCorrectness TemplateToPCUICExpanded. - + Import Transform. (** * Translation from Template to PCUIC, directly preserves evaluation *) Definition eval_pcuic_program (p : pcuic_program) (v : term) := ∥ PCUICWcbvEval.eval p.1.(trans_env_env) p.2 v ∥. - + Definition template_to_pcuic_obseq (p : template_program) (p' : pcuic_program) (v : Ast.term) (v' : term) := let Σ := Ast.Env.empty_ext p.1 in v' = trans (trans_global Σ) v. @@ -34,8 +34,8 @@ Qed. Local Obligation Tactic := idtac. -Program Definition template_to_pcuic_transform {cf : checker_flags} : - Transform.t template_program pcuic_program Ast.term term +Program Definition template_to_pcuic_transform {cf : checker_flags} : + Transform.t template_program pcuic_program Ast.term term eval_template_program eval_pcuic_program := {| name := "template to pcuic"; pre p := ∥ wt_template_program p ∥ /\ EtaExpand.expanded_program p ; @@ -60,15 +60,15 @@ Qed. From MetaCoq.PCUIC Require Import PCUICExpandLets PCUICExpandLetsCorrectness. -(** Expansion of let bindings in constructor types / case branches. - Direcly preserves evaluation as well: the new value is simply the +(** Expansion of let bindings in constructor types / case branches. + Direcly preserves evaluation as well: the new value is simply the expansion of the old one, which is the identiy on normal forms. *) Definition let_expansion_obseq (p : pcuic_program) (p' : pcuic_program) (v : term) (v' : term) := v' = PCUICExpandLets.trans v. -Program Definition pcuic_expand_lets_transform {cf : checker_flags} : +Program Definition pcuic_expand_lets_transform {cf : checker_flags} : self_transform pcuic_program term eval_pcuic_program eval_pcuic_program := {| name := "let expansion in branches/constructors"; pre p := ∥ wt_pcuic_program p ∥ /\ PCUICEtaExpand.expanded_pcuic_program p ; diff --git a/pcuic/theories/PCUICTypedAst.v b/pcuic/theories/PCUICTypedAst.v index 69cc750f1..6f8460909 100644 --- a/pcuic/theories/PCUICTypedAst.v +++ b/pcuic/theories/PCUICTypedAst.v @@ -10,7 +10,7 @@ Section Branch. Context {term : nat -> Type}. (* Parameterized by term types as they are not yet defined. *) Record branch := mk_branch { - bcontext : list (context_decl term); + bcontext : list (context_decl term); (* Context of binders of the branch, including lets. *) bbody : term; (* The branch body *) }. Derive NoConfusion for branch. @@ -22,7 +22,7 @@ Arguments branch : clear implicits. Record predicate {term} := mk_predicate { pparams : list term; (* The parameters *) puinst : Instance.t; (* The universe instance *) - pcontext : list (context_decl term); (* The predicate context, + pcontext : list (context_decl term); (* The predicate context, initially built from params and puinst *) preturn : term; (* The return type *) }. Derive NoConfusion for predicate. @@ -38,7 +38,7 @@ Inductive context_decl (term : nat -> Type) : nat -> Type := | vass {n} (na : aname) (ty : term n) : context_decl term n | vdef {n} (na : aname) (ty : term n) (body : term n) : context_decl term n. -Definition context_gen (term : nat -> Type) := +Definition context_gen (term : nat -> Type) := context (context_decl term). Definition shift n (f : nat -> Type) := @@ -47,7 +47,7 @@ Definition shift n (f : nat -> Type) := Variant FixCoFix := | Fix | CoFix. -(* Terms are well-scoped in a global environment *) +(* Terms are well-scoped in a global environment *) Variant global_reference := | ConstRef (kn : kername) @@ -66,7 +66,7 @@ Fixpoint lookup_env {term} (Σ : global_env term) (kn : kername) : option (term Definition declared_constant {term} (Σ : global_env term) (id : kername) : Type := ∑ decl, lookup_env Σ id = Some decl. -(* +(* Definition declared_minductive Σ mind decl := lookup_env Σ mind = Some (InductiveDecl decl). @@ -91,9 +91,9 @@ Inductive term {k : nat} : Type := (declared_constant Σ kn) (* | tInd ind : inductive) (ui : Instance.t) *) | tConstruct (ind : inductive) (n : nat) (ui : Instance.t) -| tCase {plen} (indn : case_info) (pparams : list term) (puinst : Instance.t) +| tCase {plen} (indn : case_info) (pparams : list term) (puinst : Instance.t) (pcontext : context_gen (shift k (@term Σ)) plen) - (c : term) + (c : term) (brs : list (∑ brlen (ctx : context_gen (@term Σ) brlen), @term Σ (brlen + k))) | tProj (p : projection) (c : term) | tFix (e : FixCoFix) {n} (mfix : Vector.t (def term) n) (idx : Fin.t n) @@ -101,7 +101,7 @@ Inductive term {k : nat} : Type := | tPrim (prim : prim_val term). with branch {n : nat} := Type := -| vass (na : aname) (t : term k) +| vass (na : aname) (t : term k) -with global_env : Type := +with global_env : Type := . diff --git a/pcuic/theories/PCUICTyping.v b/pcuic/theories/PCUICTyping.v index dc4f2c824..e13dfb256 100644 --- a/pcuic/theories/PCUICTyping.v +++ b/pcuic/theories/PCUICTyping.v @@ -261,8 +261,8 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> wf_cofixpoint Σ mfix -> Σ ;;; Γ |- tCoFix mfix n : decl.(dtype) -| type_Prim p prim_ty cdecl : - wf_local Σ Γ -> +| type_Prim p prim_ty cdecl : + wf_local Σ Γ -> primitive_constant Σ (prim_val_tag p) = Some prim_ty -> declared_constant Σ prim_ty cdecl -> primitive_invariants cdecl -> @@ -725,7 +725,7 @@ Lemma typing_ind_env_app_size `{cf : checker_flags} : All (on_def_body (lift_typing2 typing P Σ) types Γ) mfix -> wf_cofixpoint Σ mfix -> P Σ Γ (tCoFix mfix n) decl.(dtype)) -> - + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (p : prim_val term) prim_ty cdecl, PΓ Σ Γ -> primitive_constant Σ (prim_val_tag p) = Some prim_ty -> @@ -779,8 +779,8 @@ Proof. rename o0 into Xg. set (wfΣ := (ongu, o) : on_global_env cumulSpec0 (lift_typing typing) {| universes := univs; declarations := Σ |}). set (Σ':= {| universes := univs; declarations := Σ |}) in *. - destruct Xg. - rename on_global_decl_d into Xg. + destruct Xg. + rename on_global_decl_d into Xg. constructor; auto; try constructor; auto. * unshelve eset (IH' := IH ((Σ', udecl); (wfΣ; []; (tSort Universe.lProp); _; _))). shelve. simpl. apply type_Prop. @@ -802,7 +802,7 @@ Proof. eapply Alli_impl; eauto. cbn in IH. clear onI onP onnp. intros n x Xg. refine {| ind_arity_eq := Xg.(ind_arity_eq); ind_cunivs := Xg.(ind_cunivs) |}. - - apply onArity in Xg. + - apply onArity in Xg. apply lift_typing_impl with (1 := Xg); intros ? Hs. apply (IH (_; _; _; Hs)). - pose proof Xg.(onConstructors) as Xg'. @@ -1179,7 +1179,7 @@ Lemma typing_ind_env `{cf : checker_flags} : All (on_def_body (lift_typing2 typing P Σ) types Γ) mfix -> wf_cofixpoint Σ mfix -> P Σ Γ (tCoFix mfix n) decl.(dtype)) -> - + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (p : prim_val term) prim_ty cdecl, PΓ Σ Γ -> primitive_constant Σ (prim_val_tag p) = Some prim_ty -> diff --git a/pcuic/theories/PCUICUnivLevels.v b/pcuic/theories/PCUICUnivLevels.v index b598d933f..a13f96b96 100644 --- a/pcuic/theories/PCUICUnivLevels.v +++ b/pcuic/theories/PCUICUnivLevels.v @@ -1,10 +1,10 @@ -Definition fresh_levels global_levels levels := +Definition fresh_levels global_levels levels := LevelSet.For_all (fun l => ~ LevelSet.In l global_levels) levels. - - Definition declared_constraints_levels levels cstrs := + + Definition declared_constraints_levels levels cstrs := ConstraintSet.For_all (declared_cstr_levels levels) cstrs. - + Definition declared_constraints_levels_union levels cstrs cstrs' : declared_constraints_levels levels cstrs -> declared_constraints_levels levels cstrs' -> @@ -16,7 +16,7 @@ Definition fresh_levels global_levels levels := eapply ConstraintSetProp.FM.union_1 in inx as []. now eapply decl. now eapply decl'. Qed. - + Definition declared_constraints_levels_union_left levels levels' cstrs : declared_constraints_levels levels cstrs -> declared_constraints_levels (LevelSet.union levels levels') cstrs. @@ -29,7 +29,7 @@ Definition fresh_levels global_levels levels := destruct hx. now eapply LevelSetFact.union_2. Qed. - + Definition declared_constraints_levels_union_right levels levels' cstrs : declared_constraints_levels levels' cstrs -> declared_constraints_levels (LevelSet.union levels levels') cstrs. @@ -37,11 +37,11 @@ Definition fresh_levels global_levels levels := rewrite /declared_constraints_levels. intros hx x inx. specialize (hx x inx). - destruct x as [[l d] r]. + destruct x as [[l d] r]. destruct hx; split. now eapply LevelSetFact.union_3. now eapply LevelSetFact.union_3. Qed. - + Definition declared_constraints_levels_subset levels levels' cstrs : declared_constraints_levels levels cstrs -> LevelSet.Subset levels levels' -> @@ -56,30 +56,30 @@ Definition fresh_levels global_levels levels := now eapply sub. now eapply sub. Qed. - + Lemma on_udecl_spec `{checker_flags} Σ (udecl : universes_decl) : on_udecl Σ udecl = let levels := levels_of_udecl udecl in let global_levels := global_levels Σ in let all_levels := LevelSet.union levels global_levels in - fresh_levels global_levels levels + fresh_levels global_levels levels /\ declared_constraints_levels all_levels (constraints_of_udecl udecl) /\ satisfiable_udecl Σ udecl. Proof. unfold on_udecl. reflexivity. Qed. - + Lemma on_udecl_prop_spec `{checker_flags} Σ (udecl : universes_decl) : - on_udecl_prop Σ udecl = + on_udecl_prop Σ udecl = let levels := levels_of_udecl udecl in let global_levels := global_levels Σ in let all_levels := LevelSet.union levels global_levels in declared_constraints_levels all_levels (constraints_of_udecl udecl). Proof. reflexivity. Qed. - + Notation levels_of_list := LevelSetProp.of_list. - - Lemma levels_of_list_app l l' : - levels_of_list (l ++ l') = - LevelSet.union (levels_of_list l) + + Lemma levels_of_list_app l l' : + levels_of_list (l ++ l') = + LevelSet.union (levels_of_list l) (levels_of_list l'). Proof. rewrite /LevelSetProp.of_list fold_right_app. @@ -89,47 +89,47 @@ Definition fresh_levels global_levels levels := apply LevelSet.eq_leibniz. red. rewrite IHl. rewrite LevelSetProp.union_add //. Qed. - - Definition aulevels inst cstrs : - AUContext.levels (inst, cstrs) = + + Definition aulevels inst cstrs : + AUContext.levels (inst, cstrs) = LevelSetProp.of_list (unfold #|inst| Level.Var). Proof. cbn. now rewrite mapi_unfold. Qed. - + #[global] Instance unfold_proper {A} : Proper (eq ==> `=1` ==> eq) (@unfold A). Proof. intros x y -> f g eqfg. induction y; cbn; auto. f_equal; auto. f_equal. apply eqfg. Qed. - + (* sLemma unfold_add {A} n k (f : nat -> A) : skipn k (unfold (k + n) f) = unfold k (fun x => f (x + n)). *) - + Lemma unfold_add {A} n k (f : nat -> A) : unfold (n + k) f = unfold k f ++ unfold n (fun x => f (x + k)). Proof. induction n in k |- *. cbn. now rewrite app_nil_r. cbn. rewrite IHn. now rewrite app_assoc. Qed. - - - Definition unfold_levels_app n k : - LevelSetProp.of_list (unfold (n + k) Level.Var) = + + + Definition unfold_levels_app n k : + LevelSetProp.of_list (unfold (n + k) Level.Var) = LevelSet.union (LevelSetProp.of_list (unfold k Level.Var)) (LevelSetProp.of_list (unfold n (fun i => Level.Var (k + i)))). Proof. rewrite unfold_add levels_of_list_app //. now setoid_rewrite Nat.add_comm at 1. Qed. - - Lemma levels_of_list_spec l ls : + + Lemma levels_of_list_spec l ls : LevelSet.In l (levels_of_list ls) <-> In l ls. Proof. now rewrite LevelSetProp.of_list_1 InA_In_eq. Qed. - - Lemma In_unfold k l n : + + Lemma In_unfold k l n : In l (unfold n (λ i : nat, Level.Var (k + i))) <-> ∃ k' : nat, l = Level.Var k' ∧ k <= k' < k + n. Proof. induction n; cbn => //. firstorder. lia. @@ -143,14 +143,14 @@ Definition fresh_levels global_levels levels := right => //. cbn; auto. left. eapply IHn. exists k'; intuition lia. Qed. - - Lemma In_levels_of_list k l n : + + Lemma In_levels_of_list k l n : LevelSet.In l (levels_of_list (unfold n (fun i => Level.Var (k + i)))) <-> - exists k', l = Level.Var k' /\ k <= k' < k + n. + exists k', l = Level.Var k' /\ k <= k' < k + n. Proof. rewrite LevelSetProp.of_list_1 InA_In_eq. now apply In_unfold. Qed. - + Lemma In_lift_level k l n : LevelSet.In l (levels_of_list (unfold n (λ i : nat, Level.Var i))) <-> LevelSet.In (lift_level k l) (levels_of_list (unfold n (λ i : nat, Level.Var (k + i)))). Proof. @@ -161,8 +161,8 @@ Definition fresh_levels global_levels levels := eapply (In_levels_of_list 0). destruct l; noconf eq. exists n0; cbn; intuition lia. Qed. - - Lemma not_var_lift l k s : + + Lemma not_var_lift l k s : LS.For_all (λ x : LS.elt, ~~ Level.is_var x) s -> LevelSet.In l s -> LevelSet.In (lift_level k l) s. @@ -171,8 +171,8 @@ Definition fresh_levels global_levels levels := specialize (H _ H0). cbn in H. destruct l; cbn => //. Qed. - - Lemma declared_constraints_levels_lift s n k cstrs : + + Lemma declared_constraints_levels_lift s n k cstrs : LS.For_all (λ x : LS.elt, (negb ∘ Level.is_var) x) s -> declared_constraints_levels (LevelSet.union (levels_of_list (unfold n (λ i : nat, Level.Var i))) s) cstrs -> @@ -196,14 +196,14 @@ Definition fresh_levels global_levels levels := + left. now apply In_lift_level. + right. apply not_var_lift => //. Qed. - + Definition levels_of_cstr (c : ConstraintSet.elt) := let '(l, d, r) := c in LevelSet.add l (LevelSet.add r LevelSet.empty). - - Definition levels_of_cstrs cstrs := + + Definition levels_of_cstrs cstrs := ConstraintSet.fold (fun c acc => LevelSet.union (levels_of_cstr c) acc) cstrs. - + Lemma levels_of_cstrs_acc l cstrs acc : LevelSet.In l acc \/ LevelSet.In l (levels_of_cstrs cstrs LevelSet.empty) <-> LevelSet.In l (levels_of_cstrs cstrs acc). @@ -215,7 +215,7 @@ Definition fresh_levels global_levels levels := split. intros []. apply IHl0. left. now eapply LevelSetFact.union_3. apply IHl0 in H as []. apply IHl0. left. - eapply LevelSet.union_spec. left. + eapply LevelSet.union_spec. left. eapply LevelSet.union_spec in H. destruct H => //. inversion H. apply IHl0. right => //. intros. apply IHl0 in H as []. @@ -224,9 +224,9 @@ Definition fresh_levels global_levels levels := now left. right. eapply IHl0. now right. Qed. - - Lemma levels_of_cstrs_spec l cstrs : - LevelSet.In l (levels_of_cstrs cstrs LevelSet.empty) <-> + + Lemma levels_of_cstrs_spec l cstrs : + LevelSet.In l (levels_of_cstrs cstrs LevelSet.empty) <-> exists d r, ConstraintSet.In (l, d, r) cstrs \/ ConstraintSet.In (r, d, l) cstrs. Proof. rewrite -levels_of_cstrs_acc. @@ -248,7 +248,7 @@ Definition fresh_levels global_levels levels := exists d', r'. red in na. destruct h. destruct (na (l, d', r')). firstorder. firstorder. - + - intros [d [r [indr|indr]]]. rewrite /levels_of_cstrs. right. move: indr; eapply ConstraintSetProp.fold_rec. @@ -266,8 +266,8 @@ Definition fresh_levels global_levels levels := eapply add in ihih' as []; subst. left. eapply LevelSet.add_spec. right. eapply LevelSet.add_spec; now left. firstorder. Qed. - - Lemma declared_constraints_levels_in levels cstrs : + + Lemma declared_constraints_levels_in levels cstrs : LevelSet.Subset (levels_of_cstrs cstrs LevelSet.empty) levels -> declared_constraints_levels levels cstrs. Proof. @@ -276,8 +276,8 @@ Definition fresh_levels global_levels levels := split. apply (sub l). eapply levels_of_cstrs_spec. do 2 eexists; firstorder eauto. apply (sub r). eapply levels_of_cstrs_spec. do 2 eexists; firstorder eauto. Qed. - - Lemma In_variance_cstrs l d r v i i' : + + Lemma In_variance_cstrs l d r v i i' : ConstraintSet.In (l, d, r) (variance_cstrs v i i') -> (In l i \/ In l i') /\ (In r i \/ In r i'). Proof. @@ -289,13 +289,13 @@ Definition fresh_levels global_levels levels := eapply ConstraintSet.add_spec in H as []. noconf H. cbn; firstorder. eapply IHv in H; firstorder. Qed. - + Lemma In_lift l n k : In l (map (lift_level k) (unfold n Level.Var)) <-> In l (unfold n (fun i => Level.Var (k + i))). Proof. induction n; cbn; auto. firstorder. firstorder. - move: H1; rewrite map_app. + move: H1; rewrite map_app. intros [] % in_app_or. apply/in_or_app. firstorder. apply/in_or_app. firstorder. @@ -303,4 +303,3 @@ Definition fresh_levels global_levels levels := rewrite map_app. apply/in_or_app. firstorder. rewrite map_app. apply/in_or_app. firstorder. Qed. - \ No newline at end of file diff --git a/pcuic/theories/PCUICValidity.v b/pcuic/theories/PCUICValidity.v index b6d59a50c..b93ecbb5c 100644 --- a/pcuic/theories/PCUICValidity.v +++ b/pcuic/theories/PCUICValidity.v @@ -3,14 +3,14 @@ From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICLiftSubst PCUICTyping PCUICSigmaCalculus - PCUICClosed PCUICClosedConv PCUICClosedTyp PCUICWeakeningEnv PCUICWeakeningEnvTyp + PCUICClosed PCUICClosedConv PCUICClosedTyp PCUICWeakeningEnv PCUICWeakeningEnvTyp PCUICWeakeningConv PCUICWeakeningTyp PCUICInversion PCUICSubstitution PCUICReduction PCUICCumulativity PCUICGeneration PCUICUnivSubst PCUICUnivSubstitutionConv PCUICUnivSubstitutionTyp PCUICConfluence - PCUICConversion PCUICContexts + PCUICConversion PCUICContexts PCUICArities PCUICSpine PCUICInductives PCUICWellScopedCumulativity PCUICContexts PCUICWfUniverses. - + From Equations Require Import Equations. Require Import Equations.Prop.DepElim. Require Import ssreflect ssrbool. @@ -85,7 +85,7 @@ Section Validity. eapply infer_typing_sort_impl with _ Hty; intros Hs. eapply (typing_subst_instance_decl _ _ _ (tSort _)); eauto. Qed. - + Lemma isWfArity_subst_instance_decl {Σ Γ T c decl u} : wf Σ.1 -> lookup_env Σ.1 c = Some decl -> @@ -98,8 +98,8 @@ Section Validity. exists (subst_instance u ctx), (subst_instance_univ u s). rewrite (subst_instance_destArity []) eq. intuition auto. Qed. - - Lemma isType_weakening {Σ Γ T} : + + Lemma isType_weakening {Σ Γ T} : wf Σ.1 -> wf_local Σ Γ -> isType Σ [] T -> @@ -132,7 +132,7 @@ Section Validity. Lemma eq_binder_annots_eq_ctx (Σ : global_env_ext) (Δ : context) (nas : list aname) : All2 (fun x y => eq_binder_annot x y.(decl_name)) nas Δ -> - PCUICEquality.eq_context_gen (PCUICEquality.eq_term Σ Σ) (PCUICEquality.eq_term Σ Σ) + PCUICEquality.eq_context_gen (PCUICEquality.eq_term Σ Σ) (PCUICEquality.eq_term Σ Σ) (map2 set_binder_name nas Δ) Δ. Proof using Type. induction Δ in nas |- * using PCUICInduction.ctx_length_rev_ind; simpl; intros hlen. @@ -148,7 +148,7 @@ Section Validity. destruct d as [na' [d|] ty]; constructor; cbn in *; auto; try reflexivity. Qed. - + Lemma eq_term_set_binder_name (Σ : global_env_ext) (Δ : context) T U (nas : list aname) : All2 (fun x y => eq_binder_annot x y.(decl_name)) nas Δ -> PCUICEquality.eq_term Σ Σ T U -> @@ -160,10 +160,10 @@ Section Validity. - auto. - rewrite /= /mkProd_or_LetIn. destruct r => /=; intros; eapply IHa; - constructor; auto. + constructor; auto. Qed. - Lemma All2_eq_binder_subst_context_inst l s k i Δ Γ : + Lemma All2_eq_binder_subst_context_inst l s k i Δ Γ : All2 (fun (x : binder_annot name) (y : context_decl) => eq_binder_annot x (decl_name y)) l Γ -> @@ -190,7 +190,7 @@ Section Validity. Lemma wf_pre_case_predicate_context_gen {ci mdecl idecl} {p} : wf_predicate mdecl idecl p -> All2 (fun (x : binder_annot name) (y : context_decl) => eq_binder_annot x (decl_name y)) - (forget_types (pcontext p)) + (forget_types (pcontext p)) (pre_case_predicate_context_gen ci mdecl idecl (pparams p) (puinst p)). Proof using Type. move=> [] hlen /Forall2_All2. @@ -225,7 +225,7 @@ Section Validity. Theorem validity_env : env_prop (fun Σ Γ t T => isType Σ Γ T) - (fun Σ Γ => wf_local Σ Γ × All_local_env + (fun Σ Γ => wf_local Σ Γ × All_local_env (fun Γ t T => match T with Typ T => (isType Σ Γ T × Σ ;;; Γ |- t : T) | Sort => isType Σ Γ t end) Γ). Proof using Type. apply typing_ind_env; intros; rename_all_hyps. @@ -241,12 +241,12 @@ Section Validity. now apply nth_error_Some_length in heq_nth_error. now exists x. - - (* Universe *) + - (* Universe *) exists (Universe.super (Universe.super u)). constructor; auto. now apply wf_universe_super. - - - (* Product *) + + - (* Product *) eexists. eapply isType_Sort_inv in X1; eapply isType_Sort_inv in X3; auto. econstructor; eauto. @@ -289,7 +289,7 @@ Section Validity. simpl in ond. eapply isType_weakening; eauto. eapply (isType_subst_instance_decl (Γ:=[])); eauto. - + - (* Inductive type *) destruct (on_declared_inductive isdecl); pcuic. destruct isdecl. @@ -311,7 +311,7 @@ Section Validity. - (* Case predicate application *) assert (cu : consistent_instance_ext Σ (ind_universes mdecl) (puinst p)). - { eapply (isType_mkApps_Ind_inv wf isdecl) in X7 as [parsubst [argsubst Hind]]; + { eapply (isType_mkApps_Ind_inv wf isdecl) in X7 as [parsubst [argsubst Hind]]; repeat intuition auto. } eassert (ctx_inst Σ Γ _ (List.rev _)). { eapply ctx_inst_impl with (1 := X5); now intros t T [Hty _]. } @@ -337,7 +337,7 @@ Section Validity. 2:{ rewrite /predctx /case_predicate_context /case_predicate_context_gen. eapply ws_cumul_pb_compare. 1-2:eauto with fvs. 2:{ red. - instantiate (1 := + instantiate (1 := it_mkProd_or_LetIn (pre_case_predicate_context_gen ci mdecl idecl (pparams p) (puinst p)) (tSort ps)). eapply PCUICEquality.eq_term_leq_term. @@ -348,7 +348,7 @@ Section Validity. epose proof (isType_case_predicate (puinst p) _ _ wfΓ isdecl cu wfps sppars). eauto with fvs. len. rewrite (wf_predicate_length_pars H0). - now rewrite onmind.(onNpars). } + now rewrite onmind.(onNpars). } eapply wf_arity_spine_typing_spine; auto. rewrite subst_instance_app_ctx in X6. eapply spine_subst_smash_app_inv in X6 as [sppars spidx]. @@ -362,7 +362,7 @@ Section Validity. - (* Proj *) pose proof isdecl as isdecl'. eapply declared_projection_type in isdecl'; eauto. - unshelve eapply isType_mkApps_Ind_inv in X2 as [parsubst [argsubst [sppar sparg + unshelve eapply isType_mkApps_Ind_inv in X2 as [parsubst [argsubst [sppar sparg lenpars lenargs cu]]]; eauto. 2:eapply isdecl.p1. eapply infer_typing_sort_impl with _ isdecl'; intros Hs. @@ -385,15 +385,15 @@ Section Validity. rewrite subst_instance_smash. rewrite (spine_subst_subst_to_extended_list_k sppar). assumption. - + - (* Fix *) eapply nth_error_all in X0 as [s Hs]; eauto. pcuic. - + - (* CoFix *) eapply nth_error_all in X0 as [s Hs]; pcuic. - - (* Primitive *) + - (* Primitive *) destruct X0 as [s [hty hbod huniv]]. exists s@[[]]. change (tSort s@[[]]) with (tSort s)@[[]]. @@ -416,7 +416,7 @@ Defined. (* To deprecate *) Notation validity_term wf Ht := (validity (wfΣ:=wf) Ht). -(* This corollary relies strongly on validity to ensure +(* This corollary relies strongly on validity to ensure every type in the derivation is well-typed. It should be used instead of the weaker [invert_type_mkApps], which is only used as a stepping stone to validity. @@ -449,7 +449,7 @@ Proof. Qed. (** "Economical" typing rule for applications, not requiring to check the product type *) -Lemma type_App' {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ t na A B u} : +Lemma type_App' {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ t na A B u} : Σ;;; Γ |- t : tProd na A B -> Σ;;; Γ |- u : A -> Σ;;; Γ |- tApp t u : B {0 := u}. Proof. @@ -462,7 +462,7 @@ Qed. as it avoids having to give intermediate well-typing and cumulativity proofs. *) Lemma type_mkApps_arity {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ t u tty T} : Σ;;; Γ |- t : tty -> - arity_spine Σ Γ tty u T -> + arity_spine Σ Γ tty u T -> Σ;;; Γ |- mkApps t u : T. Proof. intros Ht Hty. diff --git a/pcuic/theories/PCUICWcbvEval.v b/pcuic/theories/PCUICWcbvEval.v index 2ef868d78..fa7e8f6b9 100644 --- a/pcuic/theories/PCUICWcbvEval.v +++ b/pcuic/theories/PCUICWcbvEval.v @@ -40,13 +40,13 @@ Ltac solve_discr := Definition atom t := match t with - | tInd _ _ + | tInd _ _ | tConstruct _ _ _ | tFix _ _ | tCoFix _ _ | tLambda _ _ _ | tSort _ - | tProd _ _ _ + | tProd _ _ _ | tPrim _ => true | _ => false end. @@ -226,7 +226,7 @@ Section Wcbv. context_assumptions cdecl.(cstr_args) = context_assumptions br.(bcontext) -> eval (iota_red ci.(ci_npar) p args br) res -> eval (tCase ci p discr brs) res - + (** Proj *) | eval_proj p discr args u a res mdecl idecl cdecl pdecl : declared_projection Σ p mdecl idecl cdecl pdecl -> @@ -265,11 +265,11 @@ Section Wcbv. eval discr (mkApps (tCoFix mfix idx) args) -> eval (tProj p (mkApps fn args)) res -> eval (tProj p discr) res - + (** Constructor congruence: we do not allow over-applications *) - | eval_construct ind c u mdecl idecl cdecl f args a a' : + | eval_construct ind c u mdecl idecl cdecl f args a a' : declared_constructor Σ (ind, c) mdecl idecl cdecl -> - eval f (mkApps (tConstruct ind c u) args) -> + eval f (mkApps (tConstruct ind c u) args) -> #|args| < cstr_arity mdecl cdecl -> eval a a' -> eval (tApp f a) (mkApps (tConstruct ind c u) (args ++ [a'])) @@ -310,12 +310,12 @@ Section Wcbv. value_head nargs (tConstruct ind c u) | value_head_ind ind u : value_head nargs (tInd ind u) | value_head_cofix mfix idx : value_head nargs (tCoFix mfix idx) - | value_head_fix mfix idx rarg fn : + | value_head_fix mfix idx rarg fn : cunfold_fix mfix idx = Some (rarg, fn) -> nargs <= rarg -> value_head nargs (tFix mfix idx). Derive Signature NoConfusion for value_head. - + Inductive value : term -> Type := | value_atom t : atom t -> value t | value_app_nonnil f args : value_head #|args| f -> args <> [] -> All value args -> value (mkApps f args). @@ -340,19 +340,19 @@ Section Wcbv. clear v n. revert args a. fix aux 2. destruct 1. constructor; auto. constructor. now eapply value_values_ind. now apply aux. Defined. - + Lemma value_head_nApp {nargs t} : value_head nargs t -> ~~ isApp t. Proof using Type. destruct 1; auto. Qed. Hint Resolve value_head_nApp : core. - + Lemma isStuckfix_nApp {t args} : isStuckFix t args -> ~~ isApp t. Proof using Type. destruct t; auto. Qed. Hint Resolve isStuckfix_nApp : core. - + Lemma atom_nApp {t} : atom t -> ~~ isApp t. Proof using Type. destruct t; auto. Qed. Hint Resolve atom_nApp : core. - + Lemma value_mkApps_inv t l : ~~ isApp t -> value (mkApps t l) -> @@ -363,10 +363,10 @@ Section Wcbv. intros. subst. - now eapply atom_mkApps in H. - intros * isapp appeq. move: (value_head_nApp X) => Ht. - right. + right. apply mkApps_eq_inj in appeq => //. intuition subst; auto => //. Qed. - + Lemma value_mkApps_values t l : value (mkApps t l) -> ~~ isApp t -> @@ -375,10 +375,10 @@ Section Wcbv. intros val not_app. now apply value_mkApps_inv in val as [(-> & ?)|[]]. Qed. - + (** The codomain of evaluation is only values: *) (* It means no redex can remain at the head of an evaluated term. *) - + Inductive red1 : term -> term -> Type := | red_app_left a a' b : red1 a a' -> red1 (tApp a b) (tApp a' b) @@ -395,7 +395,7 @@ Section Wcbv. red1 (tConst c u) (subst_instance u body) | red_case_in ci p discr discr' brs : red1 discr discr' -> red1 (tCase ci p discr brs) (tCase ci p discr' brs) - | red_iota ci c mdecl idecl cdecl u args p brs br : + | red_iota ci c mdecl idecl cdecl u args p brs br : nth_error brs c = Some br -> declared_constructor Σ (ci.(ci_ind), c) mdecl idecl cdecl -> #|args| = cstr_arity mdecl cdecl -> @@ -403,7 +403,7 @@ Section Wcbv. context_assumptions (cdecl.(cstr_args)) = context_assumptions br.(bcontext) -> All value args -> red1 (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) (iota_red ci.(ci_npar) p args br) - | red_proj_in discr discr' p : + | red_proj_in discr discr' p : red1 discr discr' -> red1 (tProj p discr) (tProj p discr') | red_proj p args u a mdecl idecl cdecl pdecl : declared_projection Σ p mdecl idecl cdecl pdecl -> @@ -418,14 +418,14 @@ Section Wcbv. isConstruct_app a = true -> red1 (tApp ((mkApps (tFix mfix idx) argsv)) a) (tApp (mkApps fn argsv) a) | red_cofix_proj : forall (p : projection) (mfix : mfixpoint term) - (idx : nat) (args : list term) + (idx : nat) (args : list term) (narg : nat) (fn : term), cunfold_cofix mfix idx = Some (narg, fn) -> All value args -> red1 (tProj p (mkApps (tCoFix mfix idx) args)) (tProj p (mkApps fn args)) | red_cofix_case : forall (ip : case_info) (mfix : mfixpoint term) - (idx : nat) (p : predicate term) - (args : list term) (narg : nat) + (idx : nat) (p : predicate term) + (args : list term) (narg : nat) (fn : term) (brs : list (branch term)), cunfold_cofix mfix idx = Some (narg, fn) -> All value args -> @@ -441,15 +441,15 @@ Section Wcbv. - change (tApp ?h ?a) with (mkApps h [a]). rewrite -mkApps_app. - apply value_mkApps_inv in IHev1; [|easy]. + apply value_mkApps_inv in IHev1; [|easy]. destruct IHev1 as [(-> & _)|[]]. + apply value_app; auto. len. cbn in *. econstructor; tea. cbn; auto. + depelim v. rewrite e0 in e. noconf e. eapply value_app; auto. econstructor; tea. len; lia. apply All_app_inv; auto. - - - apply value_mkApps_inv in IHev1; [|easy]. + + - apply value_mkApps_inv in IHev1; [|easy]. destruct IHev1 as [(-> & _)|[]]. + eapply value_app; cbn; auto. econstructor; tea. + eapply value_app; cbn; auto. econstructor; tea. cbn; len. lia. @@ -460,7 +460,7 @@ Section Wcbv. destruct IHev1 as [?|[]]; intuition subst. * rewrite a0 /=. rewrite a0 in i. simpl in *. - apply (value_app f0 [a']). + apply (value_app f0 [a']). destruct f0; simpl in * |- *; try congruence. all:try solve [repeat constructor; auto]. auto. @@ -486,8 +486,8 @@ Section Wcbv. destruct 1. - now constructor. - now eapply eval_atom. - - now eapply eval_atom. - - now eapply eval_atom. + - now eapply eval_atom. + - now eapply eval_atom. Qed. Lemma eval_mkApps_Construct ind c u mdecl idecl cdecl f args args' : @@ -519,7 +519,7 @@ Section Wcbv. - eapply All2_app_inv_l in evargs as [r1 [r2 [-> [evl evr]]]]. depelim evr. depelim evr. rewrite !mkApps_app /=. - eapply eval_app_cong; tea. + eapply eval_app_cong; tea. eapply IHargs => //. rewrite isFixApp_mkApps // /= isConstructApp_mkApps // !negb_or isPrimApp_mkApps. rtoProp; intuition auto. @@ -537,7 +537,7 @@ Section Wcbv. - eapply All2_app_inv_l in evargs as [r1 [r2 [-> [evl evr]]]]. depelim evr. depelim evr. rewrite !mkApps_app /=. - eapply eval_app_cong; tea. + eapply eval_app_cong; tea. eapply IHargs => //. rewrite isFixApp_mkApps // /= isConstructApp_mkApps // !negb_or isPrimApp_mkApps. rtoProp; intuition auto. @@ -558,11 +558,11 @@ Section Wcbv. rewrite !mkApps_app /=. destruct cunfold_fix as [[rarg fn]|] eqn:eqc => //. len; cbn. move/Nat.leb_le => hrarg. - eapply eval_fix_value. + eapply eval_fix_value. eapply IHargs => //. unfold isStuckFix. rewrite eqc. apply Nat.leb_le; lia. auto. tea. rewrite -(All2_length evl). lia. Qed. - + Lemma value_head_antimon {n n' f} : n' <= n -> value_head n f -> value_head n' f. Proof using Type. intros hn []; econstructor; tea. lia. lia. @@ -592,7 +592,7 @@ Section Wcbv. - now constructor. - assert (All2 eval args args). { clear -X1; induction X1; constructor; auto. } - eapply eval_mkApps_cong => //. now eapply value_head_final. + eapply eval_mkApps_cong => //. now eapply value_head_final. Qed. Lemma eval_stuck_fix args argsv mfix idx : @@ -604,9 +604,9 @@ Section Wcbv. move: H. unfold isStuckFix. destruct cunfold_fix as [[rarg fn]|] => //. now rewrite (All2_length X). Qed. - + Lemma stuck_fix_value_inv argsv mfix idx narg fn : - value (mkApps (tFix mfix idx) argsv) -> + value (mkApps (tFix mfix idx) argsv) -> cunfold_fix mfix idx = Some (narg, fn) -> (All value argsv * isStuckFix (tFix mfix idx) argsv). Proof using Type. @@ -620,7 +620,7 @@ Section Wcbv. depelim X. rewrite e. intros [= -> ->]. split => //. unfold isStuckFix. rewrite e. now apply Nat.leb_le. Qed. - + Lemma stuck_fix_value_args argsv mfix idx narg fn : value (mkApps (tFix mfix idx) argsv) -> cunfold_fix mfix idx = Some (narg, fn) -> @@ -636,7 +636,7 @@ Section Wcbv. Lemma closed_beta na t b u : closed (tLambda na t b) -> closed u -> closed (csubst u 0 b). Proof using Type. simpl; move/andP => [ct cb] cu. now eapply closed_csubst. Qed. - Lemma closed_def `{checker_flags} c decl u b : wf Σ -> declared_constant Σ c decl -> + Lemma closed_def `{checker_flags} c decl u b : wf Σ -> declared_constant Σ c decl -> cst_body decl = Some b -> closed (subst_instance u b). Proof using Type. @@ -646,7 +646,7 @@ Section Wcbv. rewrite Hb in Hc. simpl in Hc. now move/andP: Hc. Qed. - Lemma closed_iota ci ind p c u args brs br : + Lemma closed_iota ci ind p c u args brs br : forallb (test_branch_k p closedn 0) brs -> forallb (closedn 0) p.(pparams) -> closed (mkApps (tConstruct ind c u) args) -> @@ -677,11 +677,11 @@ Section Wcbv. rewrite forallb_rev. solve_all. } rewrite extended_subst_length Nat.add_0_r /= Nat.add_comm -hl. eapply closedn_lift. - rewrite inst_case_branch_context_length. + rewrite inst_case_branch_context_length. now rewrite Nat.add_0_r in clb. Qed. - Lemma closed_arg f args n a : + Lemma closed_arg f args n a : closed (mkApps f args) -> nth_error args n = Some a -> closed a. Proof using Type. @@ -690,7 +690,7 @@ Section Wcbv. solve_all. eapply All_nth_error in cargs; eauto. Qed. - Lemma closed_unfold_fix mfix idx narg fn : + Lemma closed_unfold_fix mfix idx narg fn : closed (tFix mfix idx) -> unfold_fix mfix idx = Some (narg, fn) -> closed fn. Proof using Type. @@ -704,11 +704,11 @@ Section Wcbv. discriminate. Qed. - Lemma closed_fix_substl_subst_eq {mfix idx d} : + Lemma closed_fix_substl_subst_eq {mfix idx d} : closed (tFix mfix idx) -> nth_error mfix idx = Some d -> subst0 (fix_subst mfix) (dbody d) = substl (fix_subst mfix) (dbody d). - Proof using Type. + Proof using Type. move=> /= Hf; f_equal; f_equal. have clfix : All (closedn 0) (fix_subst mfix). { clear idx. @@ -729,11 +729,11 @@ Section Wcbv. f_equal. rewrite lift_closed // closed_subst //. Qed. - Lemma closed_cofix_substl_subst_eq {mfix idx d} : + Lemma closed_cofix_substl_subst_eq {mfix idx d} : closed (tCoFix mfix idx) -> nth_error mfix idx = Some d -> subst0 (cofix_subst mfix) (dbody d) = substl (cofix_subst mfix) (dbody d). - Proof using Type. + Proof using Type. move=> /= Hf; f_equal; f_equal. have clfix : All (closedn 0) (cofix_subst mfix). { clear idx. @@ -754,7 +754,7 @@ Section Wcbv. f_equal. rewrite lift_closed // closed_subst //. Qed. - Lemma closed_unfold_fix_cunfold_eq mfix idx : + Lemma closed_unfold_fix_cunfold_eq mfix idx : closed (tFix mfix idx) -> unfold_fix mfix idx = cunfold_fix mfix idx. Proof using Type. @@ -763,11 +763,11 @@ Section Wcbv. intros cl; f_equal; f_equal. now rewrite (closed_fix_substl_subst_eq cl). Qed. - - Lemma closed_unfold_cofix_cunfold_eq mfix idx : + + Lemma closed_unfold_cofix_cunfold_eq mfix idx : closed (tCoFix mfix idx) -> unfold_cofix mfix idx = cunfold_cofix mfix idx. - Proof using Type. + Proof using Type. unfold unfold_cofix, cunfold_cofix. destruct (nth_error mfix idx) eqn:Heq => //. move=> /= Hf; f_equal; f_equal. @@ -789,7 +789,7 @@ Section Wcbv. f_equal. rewrite lift_closed // closed_subst //. Qed. - Lemma closed_unfold_cofix mfix idx narg fn : + Lemma closed_unfold_cofix mfix idx narg fn : closed (tCoFix mfix idx) -> unfold_cofix mfix idx = Some (narg, fn) -> closed fn. Proof using Type. @@ -883,11 +883,11 @@ Section Wcbv. now rewrite mkApps_app. * easy. Qed. - + Set Equations With UIP. - + Scheme Induction for le Sort Prop. - + Lemma le_irrel n m (p q : n <= m) : p = q. Proof using Type. revert q. @@ -958,7 +958,7 @@ Section Wcbv. apply mkApps_eq_inj in apps_eq as (eq1 & eq2); try easy. noconf eq1. noconf eq2. noconf IHev1. epose proof (declared_constructor_inj d d0) as [-> [-> <-]]. - pose proof e3. rewrite e in H. noconf H. + pose proof e3. rewrite e in H. noconf H. specialize (IHev2 _ ev'2). noconf IHev2. assert (e = e3) as -> by now apply uip. assert (d = d0) as -> by apply declared_constructor_unique. @@ -994,7 +994,7 @@ Section Wcbv. pose proof (mkApps_eq_inj (f_equal pr1 IHev1) eq_refl eq_refl) as (? & <-). noconf H. noconf IHev1. elimtype False. rewrite e in e0. noconf e0. lia. - + specialize (IHev1 _ ev'1). noconf IHev1. + + specialize (IHev1 _ ev'1). noconf IHev1. exfalso. rewrite isFixApp_mkApps in i; try easy. cbn in *. @@ -1071,7 +1071,7 @@ Section Wcbv. - depelim ev'; try go. now assert (i0 = i) as -> by now apply uip. Qed. - + Lemma eval_deterministic {t v v'} : eval t v -> eval t v' -> @@ -1090,7 +1090,7 @@ Section Wcbv. pose proof (eval_unique_sig ev ev'). now noconf H. Qed. - + Set SsrRewrite. Lemma eval_LetIn {n b ty t v} : diff --git a/pcuic/theories/PCUICWeakeningEnv.v b/pcuic/theories/PCUICWeakeningEnv.v index 514a81400..0bf556d26 100644 --- a/pcuic/theories/PCUICWeakeningEnv.v +++ b/pcuic/theories/PCUICWeakeningEnv.v @@ -66,9 +66,9 @@ Proof. apply global_ext_constraints_app, sub. Qed. -#[global] Instance subrel_extends_cmp {cf} pb (Σ Σ' : global_env) (ϕ : universes_decl) : +#[global] Instance subrel_extends_cmp {cf} pb (Σ Σ' : global_env) (ϕ : universes_decl) : extends Σ Σ' -> - RelationClasses.subrelation (compare_universe pb (global_ext_constraints (Σ, ϕ))) + RelationClasses.subrelation (compare_universe pb (global_ext_constraints (Σ, ϕ))) (compare_universe pb (global_ext_constraints (Σ', ϕ))). Proof. intros ext u u'. @@ -76,9 +76,9 @@ Proof. apply weakening_env_global_ext_constraints, ext. Qed. -#[global] Instance subrel_extends_eq_pb {cf} pb (Σ Σ' : global_env) (ϕ : universes_decl) : +#[global] Instance subrel_extends_eq_pb {cf} pb (Σ Σ' : global_env) (ϕ : universes_decl) : extends Σ Σ' -> - RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ, ϕ))) + RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ, ϕ))) (compare_universe pb (global_ext_constraints (Σ', ϕ))). Proof. change eq_universe with (compare_universe Conv). @@ -88,21 +88,21 @@ Proof. - transitivity (compare_universe Conv (global_ext_constraints (Σ', ϕ))); tc. Qed. -#[global] Instance subrel_extends_eq {cf} (Σ Σ' : global_env) (ϕ : universes_decl) : +#[global] Instance subrel_extends_eq {cf} (Σ Σ' : global_env) (ϕ : universes_decl) : extends Σ Σ' -> - RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ, ϕ))) + RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ, ϕ))) (eq_universe (global_ext_constraints (Σ', ϕ))). Proof. change eq_universe with (compare_universe Conv). tc. Qed. -#[global] Instance subrel_extends_le {cf} (Σ Σ' : global_env) (ϕ : universes_decl) : +#[global] Instance subrel_extends_le {cf} (Σ Σ' : global_env) (ϕ : universes_decl) : extends Σ Σ' -> - RelationClasses.subrelation (leq_universe (global_ext_constraints (Σ, ϕ))) + RelationClasses.subrelation (leq_universe (global_ext_constraints (Σ, ϕ))) (leq_universe (global_ext_constraints (Σ', ϕ))). Proof. change leq_universe with (compare_universe Cumul). tc. Qed. -#[global] Instance subrel_extends_eq_le {cf} (Σ Σ' : global_env) (ϕ : universes_decl) : +#[global] Instance subrel_extends_eq_le {cf} (Σ Σ' : global_env) (ϕ : universes_decl) : extends Σ Σ' -> - RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ, ϕ))) + RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ, ϕ))) (leq_universe (global_ext_constraints (Σ', ϕ))). Proof. change leq_universe with (compare_universe Cumul). tc. Qed. @@ -118,13 +118,13 @@ Proof. typeclasses eauto. Qed. Lemma subrelations_compare_extends {cf} Σ Σ' pb φ : extends Σ Σ' -> - RelationClasses.subrelation (compare_universe pb (global_ext_constraints (Σ,φ))) + RelationClasses.subrelation (compare_universe pb (global_ext_constraints (Σ,φ))) (compare_universe pb (global_ext_constraints (Σ',φ))). Proof. destruct pb; typeclasses eauto. Qed. Lemma subrelations_eq_compare_extends {cf} Σ Σ' pb φ : extends Σ Σ' -> - RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ,φ))) + RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ,φ))) (compare_universe pb (global_ext_constraints (Σ',φ))). Proof. destruct pb; typeclasses eauto. Qed. @@ -173,8 +173,8 @@ Lemma global_levels_sub {univs univs'} : univs ⊂_cs univs' -> LevelSet.Subset (global_levels univs) (global_levels univs'). Proof. unfold global_levels => sub. - intros x hin % LevelSet.union_spec. - apply LevelSet.union_spec. + intros x hin % LevelSet.union_spec. + apply LevelSet.union_spec. intuition auto. left. now apply sub. Qed. @@ -210,14 +210,14 @@ Definition on_udecl_prop (Σ : global_env) (udecl : universes_decl) | _ => True end. *) -Lemma in_global_levels l u : +Lemma in_global_levels l u : LevelSet.In l (ContextSet.levels u) -> LevelSet.In l (global_levels u). Proof. intros hin; now apply LevelSet.union_spec. Qed. -Lemma declared_cstr_levels_sub l l' c : +Lemma declared_cstr_levels_sub l l' c : LevelSet.Subset l l' -> declared_cstr_levels l c -> declared_cstr_levels l' c. Proof. @@ -277,7 +277,7 @@ Proof using P Pcmp cf. - simpl. auto. - intros hl. depelim hΣ. specialize (IHΣ'' c decl hΣ hl). simpl in *. - destruct (eqb_spec c kn); subst; auto. destruct o. + destruct (eqb_spec c kn); subst; auto. destruct o. apply lookup_global_Some_fresh in IHΣ''; contradiction. Qed. Hint Resolve extends_lookup : extends. @@ -395,7 +395,7 @@ Proof using P Pcmp cf. destruct H'; [now left|right]; auto. * apply LevelSet.union_spec in H''. apply LevelSet.union_spec. destruct H''; [now left|right]; auto. - + (*+ destruct d'; trivial. repeat split. * destruct H2; auto. * intros l Hl. apply H2 in Hl. @@ -418,7 +418,7 @@ Qed. Definition weaken_env_prop_full (P : global_env_ext -> context -> term -> term -> Type) := - forall (Σ : global_env_ext) (Σ' : global_env), + forall (Σ : global_env_ext) (Σ' : global_env), wf Σ -> wf Σ' -> extends Σ.1 Σ' -> forall Γ t T, P Σ Γ t T -> P (Σ', Σ.2) Γ t T. @@ -430,11 +430,11 @@ Definition weaken_env_decls_prop (P : global_env_ext -> context -> term -> typ_or_sort -> Type) := forall Σ Σ' φ, wf Σ' -> extends_decls Σ Σ' -> forall Γ t T, P (Σ, φ) Γ t T -> P (Σ', φ) Γ t T. -Lemma extends_decls_wf Σ Σ' : +Lemma extends_decls_wf Σ Σ' : wf Σ' -> extends_decls Σ Σ' -> wf Σ. Proof using P Pcmp cf. intros [onu ond] [eq [Σ'' eq']]. - split => //. + split => //. - red. rewrite eq. apply onu. - rewrite eq. rewrite eq' in ond. rewrite -e in ond. @@ -442,7 +442,7 @@ Proof using P Pcmp cf. induction Σ''; cbn; auto. intros H; depelim H. apply IHΣ''. apply H. -Qed. +Qed. End ExtendsWf. diff --git a/pcuic/theories/PCUICWellScopedCumulativity.v b/pcuic/theories/PCUICWellScopedCumulativity.v index 656788f21..3f8d63bf7 100644 --- a/pcuic/theories/PCUICWellScopedCumulativity.v +++ b/pcuic/theories/PCUICWellScopedCumulativity.v @@ -13,11 +13,11 @@ Require Import Equations.Type.Relation Equations.Type.Relation_Properties. From Equations Require Import Equations. (* We show that conversion/cumulativity starting from well-typed terms is transitive. - We first use typing to decorate the reductions/comparisons with invariants + We first use typing to decorate the reductions/comparisons with invariants showing that all the considered contexts/terms are well-scoped. In a second step - we use confluence of one-step reduction on well-scoped terms [ws_red_confluence], which also + we use confluence of one-step reduction on well-scoped terms [ws_red_confluence], which also commutes with alpha,universe-equivalence of contexts and terms [red1_eq_context_upto_l]. - We can now derive transitivity of the conversion relation on *well-scoped* + We can now derive transitivity of the conversion relation on *well-scoped* terms. To deal with the closedness side condition we put them in the definition of conversion/cumulativity: as terms need to move between contexts, and we sometimes need to consider conversion in open contexts, we work with @@ -32,7 +32,7 @@ Reserved Notation " Σ ;;; Γ ⊢ t ≤[ pb ] u" (at level 50, Γ, t, u at next Implicit Types (cf : checker_flags) (Σ : global_env_ext). Inductive ws_cumul_pb {cf} (pb : conv_pb) (Σ : global_env_ext) (Γ : context) : term -> term -> Type := -| ws_cumul_pb_compare (t u : term) : +| ws_cumul_pb_compare (t u : term) : is_closed_context Γ -> is_open_term Γ t -> is_open_term Γ u -> compare_term pb Σ.1 (global_ext_constraints Σ) t u -> Σ ;;; Γ ⊢ t ≤[pb] u | ws_cumul_pb_red_l (t u v : term) : @@ -54,7 +54,7 @@ Notation " Σ ;;; Γ ⊢ t = u " := (ws_cumul_pb Conv Σ Γ t u) (at level 50, Lemma ws_cumul_pb_refl' {pb} {cf} {Σ} (Γ : closed_context) (t : open_term Γ) : ws_cumul_pb pb Σ Γ t t. Proof. - constructor; eauto with fvs. reflexivity. + constructor; eauto with fvs. reflexivity. Qed. #[global] @@ -70,7 +70,7 @@ Proof. econstructor 2; tea. Qed. -Lemma red1_is_open_term {cf : checker_flags} {Σ} {wfΣ : wf Σ} {Γ : context} x y : +Lemma red1_is_open_term {cf : checker_flags} {Σ} {wfΣ : wf Σ} {Γ : context} x y : red1 Σ Γ x y -> is_closed_context Γ -> is_open_term Γ x -> @@ -80,7 +80,7 @@ Proof. Qed. #[global] Hint Immediate red1_is_open_term : fvs. -Lemma red_is_open_term {cf : checker_flags} {Σ} {wfΣ : wf Σ} {Γ : context} x y : +Lemma red_is_open_term {cf : checker_flags} {Σ} {wfΣ : wf Σ} {Γ : context} x y : red Σ Γ x y -> is_closed_context Γ -> is_open_term Γ x -> @@ -90,27 +90,27 @@ Proof. Qed. #[global] Hint Immediate red_is_open_term : fvs. -Lemma ws_cumul_pb_is_open_term {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} : +Lemma ws_cumul_pb_is_open_term {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} : ws_cumul_pb pb Σ Γ x y -> [&& is_closed_context Γ, is_open_term Γ x & is_open_term Γ y]. Proof. now induction 1; rewrite ?i ?i0 ?i1 ?i2. Qed. -Lemma ws_cumul_pb_is_closed_context {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} : +Lemma ws_cumul_pb_is_closed_context {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} : ws_cumul_pb pb Σ Γ x y -> is_closed_context Γ. Proof. now induction 1; rewrite ?i ?i0 ?i1 ?i2. Qed. -Lemma ws_cumul_pb_is_open_term_left {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} - {Γ : context} {x y} : +Lemma ws_cumul_pb_is_open_term_left {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} + {Γ : context} {x y} : ws_cumul_pb pb Σ Γ x y -> is_open_term Γ x. Proof. now induction 1; rewrite ?i ?i0 ?i1 ?i2. Qed. -Lemma ws_cumul_pb_is_open_term_right {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} : +Lemma ws_cumul_pb_is_open_term_right {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} : ws_cumul_pb pb Σ Γ x y -> is_open_term Γ y. Proof. now induction 1; rewrite ?i ?i0 ?i1. @@ -119,7 +119,7 @@ Qed. #[global] Hint Resolve ws_cumul_pb_is_closed_context ws_cumul_pb_is_open_term_left ws_cumul_pb_is_open_term_right : fvs. Lemma ws_cumul_pb_alt `{cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} Γ t u : - Σ ;;; Γ ⊢ t ≤[pb] u <~> + Σ ;;; Γ ⊢ t ≤[pb] u <~> ∑ v v', [× is_closed_context Γ, is_open_term Γ t, is_open_term Γ u, red Σ Γ t v, red Σ Γ u v' & compare_term pb Σ (global_ext_constraints Σ) v v']. @@ -197,7 +197,7 @@ Section EqualityLemmas. move/isType_closedPT. now rewrite closedP_shiftnP. Qed. - Lemma into_ws_cumul_pb {pb} {Γ : context} {T U} : + Lemma into_ws_cumul_pb {pb} {Γ : context} {T U} : Σ;;; Γ |- T <=[pb] U -> is_closed_context Γ -> is_open_term Γ T -> is_open_term Γ U -> @@ -210,14 +210,14 @@ Section EqualityLemmas. Qed. Lemma isType_ws_cumul_pb_refl {pb} Γ T : isType Σ Γ T -> Σ ;;; Γ ⊢ T ≤[pb] T. - Proof using wfΣ. + Proof using wfΣ. intros H. pose proof (isType_wf_local H). eapply (ws_cumul_pb_refl' (exist Γ (wf_local_closed_context X)) (exist T (isType_open H))). Qed. (** From well-typed to simply well-scoped equality. *) - Lemma wt_cumul_pb_ws_cumul_pb {pb} {Γ : context} {T U} : + Lemma wt_cumul_pb_ws_cumul_pb {pb} {Γ : context} {T U} : wt_cumul_pb pb Σ Γ T U -> ws_cumul_pb pb Σ Γ T U. Proof using wfΣ. @@ -240,7 +240,7 @@ Section EqualityLemmas. Global Instance conv_trans Γ : Transitive (wt_conv Σ Γ). Proof using wfΣ. apply wt_cumul_pb_trans. Qed. - + Global Instance cumul_trans Γ : Transitive (wt_cumul Σ Γ). Proof using wfΣ. apply wt_cumul_pb_trans. Qed. @@ -293,9 +293,9 @@ Proof. Qed. Lemma ws_cumul_pb_alt_closed {cf} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} Γ t u : - Σ ;;; Γ ⊢ t ≤[pb] u <~> + Σ ;;; Γ ⊢ t ≤[pb] u <~> ∑ v v', - [× closed_red Σ Γ t v, closed_red Σ Γ u v' & + [× closed_red Σ Γ t v, closed_red Σ Γ u v' & compare_term pb Σ (global_ext_constraints Σ) v v']. Proof. etransitivity. apply ws_cumul_pb_alt. @@ -367,7 +367,7 @@ Definition conv_cum {cf:checker_flags} pb Σ Γ T T' := Σ ;;; Γ |- T <=[pb] T'. Notation ws_decl Γ d := (on_free_vars_decl (shiftnP #|Γ| xpred0) d). - + Definition open_decl (Γ : context) := { d : context_decl | ws_decl Γ d }. Definition open_decl_proj {Γ : context} (d : open_decl Γ) := proj1_sig d. Coercion open_decl_proj : open_decl >-> context_decl. @@ -391,10 +391,10 @@ Proof. intros []; cbn; eauto with fvs. Qed. #[global] Hint Immediate ws_cumul_decls_wf_decl_left ws_cumul_decls_wf_decl_right : fvs. - -Lemma ws_cumul_decls_cumul_pb_decls {cf : checker_flags} (pb : conv_pb) {Σ : global_env_ext} {wfΣ : wf Σ} + +Lemma ws_cumul_decls_cumul_pb_decls {cf : checker_flags} (pb : conv_pb) {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' : context} {d d'} : - ws_cumul_decls pb Σ Γ d d' -> + ws_cumul_decls pb Σ Γ d d' -> cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d'. Proof. intros. intuition eauto with fvs. @@ -403,21 +403,21 @@ Qed. Lemma into_ws_cumul_decls {cf : checker_flags} {pb : conv_pb} {Σ : global_env_ext} {wfΣ : wf Σ} (Γ Γ' : context) d d' : - cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d' -> + cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d' -> on_free_vars_ctx xpred0 Γ -> on_free_vars_ctx xpred0 Γ' -> is_open_decl Γ d -> is_open_decl Γ d' -> ws_cumul_decls pb Σ Γ d d'. Proof. - case: pb; move=> pb clΓ clΓ' isd isd'; + case: pb; move=> pb clΓ clΓ' isd isd'; destruct pb; cbn; constructor; auto; try inv_on_free_vars; eauto with fvs. all:try apply: into_ws_cumul_pb; tea; eauto 3 with fvs. Qed. - -Lemma ws_cumul_decls_inv {cf} (pb : conv_pb) {Σ : global_env_ext} {wfΣ : wf Σ} + +Lemma ws_cumul_decls_inv {cf} (pb : conv_pb) {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' : context} {d d'} : - ws_cumul_decls pb Σ Γ d d' -> + ws_cumul_decls pb Σ Γ d d' -> [× on_free_vars_ctx xpred0 Γ, is_open_decl Γ d, is_open_decl Γ d' & cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d']. Proof. intros. split; eauto with fvs. @@ -450,7 +450,7 @@ Inductive wt_cumul_pb_decls {cf : checker_flags} (pb : conv_pb) (Σ : global_env conv_cum pb Σ Γ T T' -> wt_cumul_pb_decls pb Σ Γ Γ' (vdef na b T) (vdef na' b' T'). Derive Signature for wt_cumul_pb_decls. - + Definition ws_cumul_ctx_pb {cf:checker_flags} (pb : conv_pb) (Σ : global_env_ext) (Γ Γ' : context) := All2_fold (fun Γ Γ' => ws_cumul_decls pb Σ Γ) Γ Γ'. @@ -495,13 +495,13 @@ Notation wt_conv_context Σ := (wt_cumul_ctx_pb Conv Σ). Section WtContextConversion. Context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}. - Definition wt_decl Γ d := + Definition wt_decl Γ d := match d with | {| decl_body := None; decl_type := ty |} => isType Σ Γ ty | {| decl_body := Some b; decl_type := ty |} => isType Σ Γ ty × Σ ;;; Γ |- b : ty end. - Lemma wf_local_All_fold Γ : + Lemma wf_local_All_fold Γ : wf_local Σ Γ <~> All_fold wt_decl Γ. Proof using Type. @@ -544,7 +544,7 @@ Section WtContextConversion. ws_cumul_ctx_pb pb Σ Γ Γ'. Proof using wfΣ. intros a; eapply All2_fold_impl_ind; tea. - intros ???? wt ws eq; + intros ???? wt ws eq; pose proof (All2_fold_length wt). destruct eq. - pose proof (isType_wf_local i). @@ -560,7 +560,7 @@ Section WtContextConversion. eapply PCUICClosedTyp.subject_closed in t0. eapply (@closedn_on_free_vars xpred0) in t. eapply (@closedn_on_free_vars xpred0) in t0. - eapply into_ws_cumul_decls with Δ; eauto with fvs. + eapply into_ws_cumul_decls with Δ; eauto with fvs. destruct pb; constructor; auto. rewrite (All2_fold_length ws) //; eauto with fvs. Qed. @@ -574,7 +574,7 @@ Section WtContextConversion. eapply All2_fold_impl; tea; move=> ???? []; constructor; eauto with pcuic. all:try now eapply ws_cumul_pb_forget in eqt. Qed. - + #[global] Instance ws_cumul_decls_sym Γ : Symmetric (ws_cumul_decls Conv Σ Γ). Proof using Type. @@ -582,12 +582,12 @@ Section WtContextConversion. constructor; now symmetry. Qed. - Lemma ws_cumul_ctx_pb_forget {pb Γ Γ'} : + Lemma ws_cumul_ctx_pb_forget {pb Γ Γ'} : ws_cumul_ctx_pb pb Σ Γ Γ' -> cumul_pb_context cumulAlgo_gen pb Σ Γ Γ'. Proof using wfΣ. now move/ws_cumul_ctx_pb_inv => []. Qed. - + Lemma ws_cumul_ctx_pb_refl pb Γ : is_closed_context Γ -> ws_cumul_ctx_pb pb Σ Γ Γ. Proof using wfΣ. move=> onΓ. cbn. @@ -598,5 +598,5 @@ Section WtContextConversion. eapply (into_ws_cumul_decls _ Γ); auto. destruct d as [na [b|] ty]; constructor; auto; reflexivity. Qed. - + End WtContextConversion. diff --git a/pcuic/theories/PCUICWfCases.v b/pcuic/theories/PCUICWfCases.v index f98bee0d1..53584bbb5 100644 --- a/pcuic/theories/PCUICWfCases.v +++ b/pcuic/theories/PCUICWfCases.v @@ -3,11 +3,11 @@ Section WfTerm. Context (Σ : global_env). -(** Well-formedness of all the case nodes appearing in the term. - This is necessary as reduction depends on invariants on the +(** Well-formedness of all the case nodes appearing in the term. + This is necessary as reduction depends on invariants on the case representation that should match the global declarations of the inductives. *) -Equations(noind) wf_cases (t : term) : bool := +Equations(noind) wf_cases (t : term) : bool := | tRel _ => true; | tVar _ => true; | tEvar ev l => forallb wf_cases l; @@ -21,10 +21,10 @@ Equations(noind) wf_cases (t : term) : bool := | tConstruct _ _ _ => true; | tCase ci p t brs with lookup_inductive Σ ci.(ci_ind) := { | None => false; - | Some (mdecl, idecl) => + | Some (mdecl, idecl) => [&& wf_predicateb mdecl idecl p, wf_branchesb idecl brs, - forallb wf_cases p.(pparams), + forallb wf_cases p.(pparams), wf_cases t, wf_cases p.(preturn) & forallb (wf_cases ∘ bbody) brs] }; @@ -33,7 +33,7 @@ Equations(noind) wf_cases (t : term) : bool := | tCoFix mfix idx => forallb (fun d => wf_cases d.(dtype) && wf_cases d.(dbody)) mfix; | tPrim p => true. -Definition wf_cases_decl d := +Definition wf_cases_decl d := wf_cases d.(decl_type) && option_default wf_cases d.(decl_body) true. Definition wf_cases_ctx ctx := @@ -87,10 +87,10 @@ Proof. eapply forallb2_ext => cdecl b. apply map_branch_wf_branchb. Qed. -(* +(* Lemma wf_cases_rename Σ f t : wf_cases Σ (rename f t) = wf_cases Σ t. Proof. - induction t in f |- * using PCUICInduction.term_forall_list_ind; simpl; auto; + induction t in f |- * using PCUICInduction.term_forall_list_ind; simpl; auto; rewrite ?forallb_map; solve_all. - eapply All_forallb_eq_forallb; eauto. - destruct (lookup_inductive) as [[mdecl idecl]|] => /= //. @@ -112,7 +112,7 @@ Qed. Lemma wf_cases_fix_context Σ mfix : forallb (fun d : def term => wf_cases Σ (dtype d) && wf_cases Σ (dbody d)) - mfix -> + mfix -> wf_cases_ctx Σ (fix_context mfix). Proof. rewrite /wf_cases_ctx /fix_context. diff --git a/pcuic/theories/PCUICWfUniverses.v b/pcuic/theories/PCUICWfUniverses.v index 04b559f69..ded1ddd32 100644 --- a/pcuic/theories/PCUICWfUniverses.v +++ b/pcuic/theories/PCUICWfUniverses.v @@ -24,7 +24,7 @@ Section CheckerFlags. subst l. simpl. apply global_ext_levels_InSet. Qed. - + Lemma wf_universe_type1 Σ : wf_universe Σ Universe.type1. Proof using Type. simpl. @@ -39,7 +39,7 @@ Section CheckerFlags. 1-2:intros _ l hin%LevelExprSet.singleton_spec; subst l; apply wf_universe_type1; now apply LevelExprSet.singleton_spec. intros Hl. - intros l hin. + intros l hin. eapply Universes.spec_map_succ in hin as [x' [int ->]]. simpl. now specialize (Hl _ int). Qed. @@ -52,7 +52,7 @@ Section CheckerFlags. now apply (Hu _ Hl). now apply (Hu' _ Hl). Qed. - + Lemma wf_universe_product {Σ u u'} : wf_universe Σ u -> wf_universe Σ u' -> wf_universe Σ (Universe.sort_of_product u u'). Proof using Type. @@ -64,12 +64,12 @@ Section CheckerFlags. Hint Resolve wf_universe_type1 wf_universe_super wf_universe_sup wf_universe_product : pcuic. - Definition wf_universeb_level Σ l := + Definition wf_universeb_level Σ l := LevelSet.mem l (global_ext_levels Σ). - Definition wf_universe_level Σ l := + Definition wf_universe_level Σ l := LevelSet.In l (global_ext_levels Σ). - + Definition wf_universe_instance Σ u := Forall (wf_universe_level Σ) u. @@ -90,12 +90,12 @@ Section CheckerFlags. unfold wf_universe_instance, wf_universeb_instance. apply forallbP. intros x; apply wf_universe_levelP. Qed. - + Lemma wf_universe_subst_instance_univ (Σ : global_env_ext) univs u s : wf Σ -> wf_universe Σ s -> wf_universe_instance (Σ.1, univs) u -> - wf_universe (Σ.1, univs) (subst_instance u s). + wf_universe (Σ.1, univs) (subst_instance u s). Proof using Type. destruct s as [| |t]; cbnr. intros wfΣ Hl Hu e [[l n] [inl ->]]%In_subst_instance. @@ -118,7 +118,7 @@ Section CheckerFlags. * unfold subst_instance. simpl. destruct (nth_error u n') eqn:hnth. 2:{ simpl. rewrite hnth. apply global_ext_levels_InSet. } - eapply nth_error_forall in Hu. 2:eauto. + eapply nth_error_forall in Hu. 2:eauto. change (nth_error u n') with (nth_error u n') in *. rewrite -> hnth. simpl. apply Hu. + now apply not_var_global_levels in Hl. @@ -134,7 +134,7 @@ Section CheckerFlags. apply (wf_universe_subst_instance_univ (Σ, univs) φ); auto. Qed. - Lemma subst_instance_empty u : + Lemma subst_instance_empty u : forallb (fun x => ~~ Level.is_var x) u -> subst_instance [] u = u. Proof using Type. @@ -145,7 +145,7 @@ Section CheckerFlags. now destruct a => /= //; auto. Qed. - Lemma wf_universe_level_mono Σ u : + Lemma wf_universe_level_mono Σ u : wf Σ -> on_udecl_prop Σ (Monomorphic_ctx) -> Forall (wf_universe_level (Σ, Monomorphic_ctx)) u -> @@ -181,7 +181,7 @@ Section CheckerFlags. intros. red in H. cbn in H. eapply wf_universe_level_sub; eauto. Qed. - Lemma In_Level_global_ext_poly s Σ cst : + Lemma In_Level_global_ext_poly s Σ cst : LS.In (Level.Level s) (global_ext_levels (Σ, Polymorphic_ctx cst)) -> LS.In (Level.Level s) (global_levels Σ). Proof using Type. @@ -198,7 +198,7 @@ Section CheckerFlags. intros x' [->|inx]; auto. Qed. - Lemma wf_universe_instance_In {Σ u} : wf_universe_instance Σ u <-> + Lemma wf_universe_instance_In {Σ u} : wf_universe_instance Σ u <-> (forall l, In l u -> LS.In l (global_ext_levels Σ)). Proof using Type. unfold wf_universe_instance. @@ -206,7 +206,7 @@ Section CheckerFlags. apply In_Forall. auto. Qed. - Lemma in_subst_instance l u u' : + Lemma in_subst_instance l u u' : In l (subst_instance u u') -> In l u \/ In l u' \/ l = Level.lzero. Proof using Type. @@ -217,7 +217,7 @@ Section CheckerFlags. specialize (IHu' H). intuition auto. Qed. - Lemma wf_universe_subst_instance Σ univs u u' φ : + Lemma wf_universe_subst_instance Σ univs u u' φ : wf Σ -> on_udecl_prop Σ univs -> wf_universe_instance (Σ, univs) u' -> @@ -261,7 +261,7 @@ Section CheckerFlags. | _ => true end. - Lemma wf_universe_reflect {u : Universe.t} : + Lemma wf_universe_reflect {u : Universe.t} : reflect (wf_universe Σ u) (wf_universeb u). Proof using Type. destruct u; simpl; try now constructor. @@ -274,7 +274,7 @@ Section CheckerFlags. now eapply LS.mem_spec in H. Qed. - Fixpoint on_universes fu fc t := + Fixpoint on_universes fu fc t := match t with | tSort s => fu s | tApp t u @@ -285,7 +285,7 @@ Section CheckerFlags. forallb fu (map Universe.make p.(puinst)) , forallb (on_universes fu fc) p.(pparams) , test_context (fc #|p.(puinst)|) p.(pcontext) , - on_universes fu fc p.(preturn) , + on_universes fu fc p.(preturn) , on_universes fu fc c & forallb (test_branch (fc #|p.(puinst)|) (on_universes fu fc)) brs ] | tLetIn _ t t' u => @@ -301,7 +301,7 @@ Section CheckerFlags. Definition wf_universes t := on_universes wf_universeb closedu t. - + Lemma wf_universeb_instance_forall u : forallb wf_universeb (map Universe.make u) = wf_universeb_instance Σ u. @@ -400,19 +400,19 @@ Qed. End WfUniverses. Arguments wf_universe_reflect {Σ u}. - Ltac to_prop := - repeat match goal with + Ltac to_prop := + repeat match goal with | [ H: is_true (?x && ?y) |- _ ] => let x := fresh in let y := fresh in move/andP: H; move=> [x y]; rewrite ?x ?y; simpl - end. + end. - Ltac to_wfu := - repeat match goal with + Ltac to_wfu := + repeat match goal with | [ H: is_true (wf_universeb _ ?x) |- _ ] => apply (elimT (@wf_universe_reflect _ x)) in H | [ |- is_true (wf_universeb _ ?x) ] => apply (introT (@wf_universe_reflect _ x)) end. - - Lemma wf_universes_inst {Σ : global_env_ext} univs t u : + + Lemma wf_universes_inst {Σ : global_env_ext} univs t u : wf Σ -> on_udecl_prop Σ.1 univs -> wf_universe_instance Σ u -> @@ -420,7 +420,7 @@ Qed. wf_universes Σ (subst_instance u t). Proof using Type. intros wfΣ onudecl cu wft. - induction t using term_forall_list_ind; simpl in *; auto; try to_prop; + induction t using term_forall_list_ind; simpl in *; auto; try to_prop; try apply /andP; to_wfu; intuition eauto 4. all:cbn in * ; autorewrite with map; repeat (f_equal; solve_all). @@ -452,7 +452,7 @@ Qed. eapply wf_universe_subst_instance; eauto. destruct Σ; simpl in *. now move/wf_universe_instanceP: wft. - + - apply forallb_All. rewrite -forallb_map wf_universeb_instance_forall. apply All_forallb in H. @@ -461,14 +461,14 @@ Qed. eapply wf_universe_subst_instance; eauto. destruct Σ ; simpl in *. now move/wf_universe_instanceP: H. - - - now len. + + - now len. - rewrite /test_branch. rtoProp. move/andP: a => [] tctx wfu. split; auto. simpl. solve_all. now len. Qed. - + Lemma weaken_wf_universe Σ Σ' t : wf Σ' -> extends Σ.1 Σ' -> wf_universe Σ t -> wf_universe (Σ', Σ.2) t. @@ -531,10 +531,10 @@ Qed. rtoProp. intuition. - red in X; solve_all. - - red in X. solve_all. + - red in X. solve_all. Qed. - Lemma wf_universes_weaken_full : weaken_env_prop_full cumulSpec0 (lift_typing typing) (fun Σ Γ t T => + Lemma wf_universes_weaken_full : weaken_env_prop_full cumulSpec0 (lift_typing typing) (fun Σ Γ t T => wf_universes Σ t && wf_universes Σ T). Proof using Type. red. intros. @@ -551,7 +551,7 @@ Qed. now eapply (wf_universes_weaken_full (Σ, _)). Qed. - Lemma wf_universes_inds Σ mind u bodies : + Lemma wf_universes_inds Σ mind u bodies : wf_universe_instance Σ u -> All (fun t : term => wf_universes Σ t) (inds mind u bodies). Proof using Type. @@ -565,13 +565,13 @@ Qed. now apply /wf_universe_instanceP. Qed. - Lemma wf_universes_mkApps Σ f args : + Lemma wf_universes_mkApps Σ f args : wf_universes Σ (mkApps f args) = wf_universes Σ f && forallb (wf_universes Σ) args. Proof using Type. induction args using rev_ind; simpl; auto. now rewrite andb_true_r. now rewrite mkApps_app forallb_app /= andb_true_r andb_assoc -IHargs. Qed. - + Lemma type_local_ctx_wf Σ Γ Δ s : type_local_ctx (lift_typing (fun (Σ : PCUICEnvironment.global_env_ext) @@ -638,8 +638,8 @@ Qed. - now rewrite wf_universes_lift. Qed. - Lemma wf_sorts_local_ctx_nth_error Σ P Γ Δ s n d : - sorts_local_ctx P Σ Γ Δ s -> + Lemma wf_sorts_local_ctx_nth_error Σ P Γ Δ s n d : + sorts_local_ctx P Σ Γ Δ s -> nth_error Δ n = Some d -> ∑ Γ' t, P Σ Γ' (decl_type d) t. Proof using Type. @@ -666,7 +666,7 @@ Qed. induction n in k, lt |- *. lia. simpl. apply in_or_app. destruct (lt_dec k n). left; auto. - right. left. f_equal. lia. + right. left. f_equal. lia. Qed. Lemma wf_abstract_instance Σ decl : @@ -697,8 +697,8 @@ Qed. Definition wf_ctx_universes Σ Γ := forallb (wf_decl_universes Σ) Γ. - - Lemma wf_universes_it_mkProd_or_LetIn {Σ Γ T} : + + Lemma wf_universes_it_mkProd_or_LetIn {Σ Γ T} : wf_universes Σ (it_mkProd_or_LetIn Γ T) = wf_ctx_universes Σ Γ && wf_universes Σ T. Proof using Type. induction Γ as [ |[na [b|] ty] Γ] using rev_ind ; simpl; auto; @@ -709,7 +709,7 @@ Qed. Qed. - Lemma test_context_app p Γ Δ : + Lemma test_context_app p Γ Δ : test_context p (Γ ,,, Δ) = test_context p Γ && test_context p Δ. Proof using Type. induction Δ; simpl; auto. @@ -717,8 +717,8 @@ Qed. - now rewrite IHΔ andb_assoc. Qed. - - Lemma wf_universes_it_mkLambda_or_LetIn {Σ Γ T} : + + Lemma wf_universes_it_mkLambda_or_LetIn {Σ Γ T} : wf_universes Σ (it_mkLambda_or_LetIn Γ T) = test_context (wf_universes Σ) Γ && wf_universes Σ T. Proof using Type. induction Γ as [ |[na [b|] ty] Γ] using rev_ind; simpl; auto; @@ -726,7 +726,7 @@ Qed. /= -!/(wf_universes _ _) IHΓ test_context_app /= /test_decl /= ; repeat bool_congr. Qed. - + Lemma wf_projs Σ ind npars p : All (fun t : term => wf_universes Σ t) (projs ind npars p). Proof using Type. @@ -760,7 +760,7 @@ Qed. Qed. Lemma closedu_abstract_instance univs : closedu_instance #|abstract_instance univs| (abstract_instance univs). - Proof using Type. + Proof using Type. destruct univs as [|[l csts]] => // /=. rewrite /UContext.instance /AUContext.repr. rewrite /closedu_instance forallb_mapi //. @@ -784,9 +784,9 @@ Qed. - rewrite /test_def /map_def /=. now rewrite a b. Qed. - Ltac try_hyp := + Ltac try_hyp := multimatch goal with H : _ |- _ => eapply H end. - + Ltac crush := repeat (solve_all; try try_hyp; cbn). @@ -817,7 +817,7 @@ Qed. rewrite fold_context_k_snoc0 /= IHΓ //. crush. unfold test_decl in *. crush. destruct decl_body eqn:heq => /= //. - rewrite closedu_subst //. crush. + rewrite closedu_subst //. crush. rewrite closedu_subst //. crush. Qed. @@ -828,20 +828,20 @@ Qed. induction Γ. * cbn; auto. * rtoProp. - rewrite fold_context_k_snoc0 /= IHΓ //. - unfold test_decl in *. + rewrite fold_context_k_snoc0 /= IHΓ //. + unfold test_decl in *. cbn. - rewrite closedu_lift. + rewrite closedu_lift. destruct (decl_body a) => /= //. rewrite closedu_lift //. Qed. - Lemma closedu_extended_subst k Γ k' : + Lemma closedu_extended_subst k Γ k' : closedu_ctx k Γ -> forallb (closedu k) (extended_subst Γ k'). Proof using Type. induction Γ in k' |- *; cbn; auto. destruct a as [na [b|] ty] => /= //. - unfold test_decl; move/andP=> [] clΓ /= cld. apply/andP. split. + unfold test_decl; move/andP=> [] clΓ /= cld. apply/andP. split. eapply closedu_subst. rewrite IHΓ // /= closedu_lift. crush. now rewrite IHΓ. unfold test_decl; move/andP=> [] clΓ /= cld. now apply IHΓ. @@ -849,7 +849,7 @@ Qed. Lemma closedu_expand_lets_ctx k Γ Δ : closedu_ctx k Γ && closedu_ctx k Δ -> - closedu_ctx k (expand_lets_ctx Γ Δ). + closedu_ctx k (expand_lets_ctx Γ Δ). Proof using Type. rewrite /expand_lets_ctx /expand_lets_k_ctx. move/andP => [] clΓ clΔ. @@ -859,7 +859,7 @@ Qed. Lemma closedu_smash_context_gen k Γ Δ : closedu_ctx k Γ -> closedu_ctx k Δ -> - closedu_ctx k (smash_context Γ Δ). + closedu_ctx k (smash_context Γ Δ). Proof using Type. induction Δ in Γ |- *; cbn; auto. move=> clΓ /andP[] clΔ cla. @@ -869,19 +869,19 @@ Qed. - apply IHΔ => //. now rewrite test_context_app clΓ /= andb_true_r. Qed. - + Lemma closedu_smash_context k Δ : closedu_ctx k Δ -> - closedu_ctx k (smash_context [] Δ). + closedu_ctx k (smash_context [] Δ). Proof using Type. apply closedu_smash_context_gen => //. Qed. - + Lemma wf_universe_level_closed {Σ : global_env} {wfΣ : wf Σ} univs u : on_udecl_prop Σ univs -> wf_universe_level (Σ, univs) u -> closedu_level #|polymorphic_instance univs| u. Proof using Type. - intros ond Ht; destruct u => //. + intros ond Ht; destruct u => //. cbn in Ht. unfold closedu_universe, closedu_universe_levels. cbn. red in Ht. eapply in_var_global_ext in Ht => //. @@ -901,7 +901,7 @@ Qed. on_udecl_prop Σ univs -> wf_universe (Σ, univs) u -> closedu #|polymorphic_instance univs| (tSort u). Proof using Type. - intros ond Ht; destruct u => //. + intros ond Ht; destruct u => //. cbn in Ht. unfold closedu_universe, closedu_universe_levels. eapply LevelExprSet.for_all_spec. intros x y ?; subst; auto. @@ -912,7 +912,7 @@ Qed. Lemma wf_universe_instance_closed {Σ : global_env} {wfΣ : wf Σ} {univs u} : on_udecl_prop Σ univs -> - wf_universe_instance (Σ, univs) u -> + wf_universe_instance (Σ, univs) u -> closedu_instance #|polymorphic_instance univs| u. Proof using Type. intros ond Ht. @@ -959,13 +959,13 @@ Qed. rewrite IHctx // /=. unfold wf_decl_universes, test_decl in *. destruct a as [na [b|] ty]; cbn in *. - move/andP: wfa => []. + move/andP: wfa => []. now do 2 move/(wf_universes_closedu ond) => ->. now move/(wf_universes_closedu ond): wfa => ->. Qed. - Lemma closedu_reln k Γ k' acc : + Lemma closedu_reln k Γ k' acc : closedu_ctx k Γ -> forallb (closedu k) acc -> forallb (closedu k) (reln acc k' Γ). @@ -976,7 +976,7 @@ Qed. - unfold test_decl; move/andP=> [] clΓ /= cld clacc; now apply IHΓ => //. Qed. - Lemma closedu_to_extended_list_k k Γ k' : + Lemma closedu_to_extended_list_k k Γ k' : closedu_ctx k Γ -> forallb (closedu k) (to_extended_list_k Γ k'). Proof using Type. @@ -1015,7 +1015,7 @@ Qed. Qed. Theorem wf_types : - env_prop (fun Σ Γ t T => + env_prop (fun Σ Γ t T => wf_universes Σ t && wf_universes Σ T) (fun Σ Γ => All_local_env @@ -1047,7 +1047,7 @@ Qed. + destruct X as [s Hs]. now to_prop. - apply/andP; split; to_wfu; cbn ; eauto with pcuic. - + - cbn in *; to_wfu ; eauto with pcuic. - rewrite wf_universes_subst. constructor. to_wfu; auto. constructor. now move/andP: H4 => []. @@ -1095,12 +1095,12 @@ Qed. eapply wf_universes_inst; eauto. exact (weaken_lookup_on_global_env' Σ.1 _ _ wf (proj1 (proj1 isdecl))). now eapply consistent_instance_ext_wf. - + - rewrite wf_universes_mkApps in H5. move/andP: H5 => /= [] wfu; rewrite forallb_app. move/andP=> [] wfpars wfinds. cbn in wfu. - rewrite wfu /= wfpars wf_universes_mkApps /= + rewrite wfu /= wfpars wf_universes_mkApps /= forallb_app wfinds /= H /= !andb_true_r. pose proof (declared_inductive_inv wf_universes_weaken wf X isdecl). destruct X5. destruct onArity as [s Hs]. @@ -1153,7 +1153,7 @@ Qed. destruct ind_cunivs as [|cunivs []] => //; destruct X1 as [[[? ?] ?] ?] => //. red in o0. - destruct nth_error eqn:heq => //. + destruct nth_error eqn:heq => //. destruct o0 as [_ ->]. rewrite wf_universes_mkApps {1}/wf_universes /= -!/(wf_universes _ _) wf_universeb_instance_forall in H1. @@ -1186,8 +1186,8 @@ Qed. eapply wf_sorts_local_ctx_smash in s. eapply wf_sorts_local_ctx_nth_error in s as [? [? H]]; eauto. red in H. destruct x0. now move/andP: H => []. - now destruct H as [s [Hs _]%andb_and]. - + now destruct H as [s [Hs _]%andb_and]. + - apply/andP; split; auto. solve_all; destruct a0 as (? & _ & ?), b0; rtoProp; tas. eapply nth_error_all in X0; eauto. @@ -1199,7 +1199,7 @@ Qed. simpl in X0. now move: X0 => [s [Hty /andP[wfty _]]]. Qed. - Lemma typing_wf_universes {Σ : global_env_ext} {Γ t T} : + Lemma typing_wf_universes {Σ : global_env_ext} {Γ t T} : wf Σ -> Σ ;;; Γ |- t : T -> wf_universes Σ t && wf_universes Σ T. Proof using Type. @@ -1207,7 +1207,7 @@ Qed. exact (env_prop_typing wf_types _ wfΣ _ _ _ Hty). Qed. - Lemma typing_wf_universe {Σ : global_env_ext} {Γ t s} : + Lemma typing_wf_universe {Σ : global_env_ext} {Γ t s} : wf Σ -> Σ ;;; Γ |- t : tSort s -> wf_universe Σ s. Proof using Type. @@ -1220,14 +1220,14 @@ Qed. Proof using Type. intros wfΣ [s Hs]. now eapply typing_wf_universes in Hs as [HT _]%andb_and. Qed. - + End CheckerFlags. Arguments wf_universe_reflect {Σ u}. #[global] Hint Resolve wf_universe_type1 wf_universe_super wf_universe_sup wf_universe_product : pcuic. #[global] -Hint Extern 4 (wf_universe _ ?u) => +Hint Extern 4 (wf_universe _ ?u) => match goal with [ H : typing _ _ _ (tSort u) |- _ ] => apply (typing_wf_universe _ H) end : pcuic. diff --git a/pcuic/theories/PCUICWtCumulativity.v b/pcuic/theories/PCUICWtCumulativity.v index ced93c5dd..9cfee320f 100644 --- a/pcuic/theories/PCUICWtCumulativity.v +++ b/pcuic/theories/PCUICWtCumulativity.v @@ -22,7 +22,7 @@ Coercion wt_cumul_pb_ws_cumul_pb : wt_cumul_pb >-> equality. Section WtEquality. Context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}. - + Lemma type_wt_cumul_pb {le Γ t} T {U} : Σ ;;; Γ |- t : T -> Σ ;;; Γ ⊢ T ≤[le] U ✓ -> diff --git a/pcuic/theories/Syntax/PCUICCases.v b/pcuic/theories/Syntax/PCUICCases.v index dbc1ef550..ca49362d7 100644 --- a/pcuic/theories/Syntax/PCUICCases.v +++ b/pcuic/theories/Syntax/PCUICCases.v @@ -105,7 +105,7 @@ Proof. rewrite /cstr_branch_context. now len. Qed. #[global] Hint Rewrite cstr_branch_context_length : len. -Lemma cstr_branch_context_assumptions ci mdecl cdecl : +Lemma cstr_branch_context_assumptions ci mdecl cdecl : context_assumptions (cstr_branch_context ci mdecl cdecl) = context_assumptions (cstr_args cdecl). Proof. @@ -411,7 +411,7 @@ Lemma fix_context_length mfix : #|fix_context mfix| = #|mfix|. Proof. unfold fix_context. now rewrite List.rev_length mapi_length. Qed. #[global] -Hint Rewrite subst_instance_length +Hint Rewrite subst_instance_length fix_context_length fix_subst_length cofix_subst_length : len. Definition is_constructor n ts := @@ -419,14 +419,14 @@ Definition is_constructor n ts := | Some a => isConstruct_app a | None => false end. - + Lemma is_constructor_app_ge n l l' : is_constructor n l -> is_constructor n (l ++ l'). Proof. unfold is_constructor. destruct nth_error eqn:Heq => //. rewrite nth_error_app_lt ?Heq //; eauto using nth_error_Some_length. Qed. -Lemma is_constructor_prefix n args args' : +Lemma is_constructor_prefix n args args' : ~~ is_constructor n (args ++ args') -> ~~ is_constructor n args. Proof. @@ -439,5 +439,4 @@ Proof. - rewrite app_length. move=> ge _. elim: nth_error_spec; intros; try lia. auto. Qed. - - \ No newline at end of file + diff --git a/pcuic/theories/Syntax/PCUICClosed.v b/pcuic/theories/Syntax/PCUICClosed.v index 693bcf2d7..e33408697 100644 --- a/pcuic/theories/Syntax/PCUICClosed.v +++ b/pcuic/theories/Syntax/PCUICClosed.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import Morphisms. +From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction PCUICUnivSubst PCUICLiftSubst PCUICSigmaCalculus. @@ -22,7 +22,7 @@ Proof. - move=> cty k' lek'; rewrite (@closed_upwards k) //. Qed. -Lemma alli_fold_context_k (p : nat -> context_decl -> bool) ctx f : +Lemma alli_fold_context_k (p : nat -> context_decl -> bool) ctx f : (forall i d, p i d -> map_decl (f i) d = d) -> alli p 0 (List.rev ctx) -> fold_context_k f ctx = ctx. @@ -68,14 +68,14 @@ Proof. f_equal. rewrite IHctx // lift_decl_closed // Nat.add_comm //. Qed. -Lemma map_decl_closed_ext (f : term -> term) g k (d : context_decl) : closed_decl k d -> - (forall x, closedn k x -> f x = g x) -> +Lemma map_decl_closed_ext (f : term -> term) g k (d : context_decl) : closed_decl k d -> + (forall x, closedn k x -> f x = g x) -> map_decl f d = map_decl g d. Proof. destruct d as [? [?|] ?] => /= cl Hfg; unfold map_decl; simpl; f_equal. rewrite Hfg => //. unfold closed_decl in cl. - simpl in cl. now move/andP: cl => []. + simpl in cl. now move/andP: cl => []. move/andP: cl => [cl cl']. now rewrite Hfg. now rewrite Hfg. Qed. @@ -136,7 +136,7 @@ Proof. simpl in *; autorewrite with map; simpl closed in *; repeat (rtoProp; simpl in *; solve_all); try change_Sk; - unfold test_def, test_predicate_k, test_branch_k, shiftf in *; + unfold test_def, test_predicate_k, test_branch_k, shiftf in *; rewrite -> ?map_length, ?Nat.add_assoc in *; simpl in *; eauto 2 with all. @@ -170,7 +170,7 @@ Qed. #[global] Remove Hints absurd_eq_true trans_eq_bool f_equal2_nat f_equal_nat : core. Lemma closedn_subst_eq s k k' t : - forallb (closedn k) s -> + forallb (closedn k) s -> closedn (k + k' + #|s|) t = closedn (k + k') (subst s k' t). Proof. @@ -215,12 +215,12 @@ Proof. - rewrite a //. specialize (b (#|m| + k')). rewrite Nat.add_assoc in b. - rewrite (Nat.add_comm k #|m|) in b. + rewrite (Nat.add_comm k #|m|) in b. rewrite b //. - rewrite a //. specialize (b (#|m| + k')). rewrite Nat.add_assoc in b. - rewrite (Nat.add_comm k #|m|) in b. + rewrite (Nat.add_comm k #|m|) in b. rewrite b //. Qed. @@ -264,16 +264,16 @@ Proof. simpl in H2. len in H2. rewrite !Nat.add_assoc in H2. eauto. - move/andP: b => [hty hbod]. rewrite a0 //. specialize (b0 (#|m| + k')). - rewrite Nat.add_assoc (Nat.add_comm k #|m|) in b0. + rewrite Nat.add_assoc (Nat.add_comm k #|m|) in b0. rewrite b0 //. now autorewrite with len in hbod. - move/andP: b => [hty hbod]. rewrite a0 //. specialize (b0 (#|m| + k')). - rewrite Nat.add_assoc (Nat.add_comm k #|m|) in b0. + rewrite Nat.add_assoc (Nat.add_comm k #|m|) in b0. rewrite b0 //. now autorewrite with len in hbod. Qed. Lemma closedn_subst s k k' t : - forallb (closedn k) s -> + forallb (closedn k) s -> closedn (k + k' + #|s|) t -> closedn (k + k') (subst s k' t). Proof. @@ -316,8 +316,8 @@ Proof. do 3 (f_equal; intuition eauto). Qed. -Lemma closed_map_subst_instance n u l : - forallb (closedn n) (map (subst_instance u) l) = +Lemma closed_map_subst_instance n u l : + forallb (closedn n) (map (subst_instance u) l) = forallb (closedn n) l. Proof. induction l; simpl; auto. @@ -344,7 +344,7 @@ Proof. Qed. Lemma closedn_it_mkProd_or_LetIn n (ctx : list context_decl) T : - closedn n (it_mkProd_or_LetIn ctx T) = + closedn n (it_mkProd_or_LetIn ctx T) = closedn_ctx n ctx && closedn (n + #|ctx|) T. Proof. induction ctx in n, T |- *. simpl. @@ -376,7 +376,7 @@ Definition Pclosed := Lemma closed_subst_context n (Δ Δ' : context) t : closedn (n + #|Δ|) t -> - Alli (fun i d => closed_decl (n + S #|Δ| + i) d) 0 (List.rev Δ') -> + Alli (fun i d => closed_decl (n + S #|Δ| + i) d) 0 (List.rev Δ') -> Alli (fun i d => closed_decl (n + #|Δ| + i) d) 0 (List.rev (subst_context [t] 0 Δ')). Proof. induction Δ' in Δ |- *. @@ -385,7 +385,7 @@ Proof. - intros. eapply Alli_app in X as [X X']. rewrite subst_context_snoc. simpl. eapply Alli_app_inv. eapply IHΔ'; eauto. constructor; [|constructor]. - simpl. + simpl. rewrite /test_decl /map_decl /= Nat.add_0_r List.rev_length subst_context_length. inv X'. unfold test_decl in H0. simpl in H0. rewrite List.rev_length Nat.add_0_r in H0. @@ -394,7 +394,7 @@ Proof. - intros. eapply Alli_app in X as [X X']. rewrite subst_context_snoc. simpl. eapply Alli_app_inv. eapply IHΔ'; eauto. constructor; [|constructor]. - simpl. + simpl. rewrite /test_decl /map_decl /= Nat.add_0_r List.rev_length subst_context_length. inv X'. unfold test_decl in H0. simpl in H0. rewrite List.rev_length Nat.add_0_r in H0. @@ -402,8 +402,8 @@ Proof. Qed. Lemma closed_smash_context_gen n (Δ Δ' : context) : - Alli (fun i d => closed_decl (n + i) d) 0 (List.rev Δ) -> - Alli (fun i d => closed_decl (n + #|Δ| + i) d) 0 (List.rev Δ') -> + Alli (fun i d => closed_decl (n + i) d) 0 (List.rev Δ) -> + Alli (fun i d => closed_decl (n + #|Δ| + i) d) 0 (List.rev Δ') -> Alli (fun i d => closed_decl (n + i) d) 0 (List.rev (smash_context Δ' Δ)). Proof. induction Δ in Δ' |- *. @@ -429,7 +429,7 @@ Proof. Qed. Lemma closed_smash_context_unfold n (Δ : context) : - Alli (fun i d => closed_decl (n + i) d) 0 (List.rev Δ) -> + Alli (fun i d => closed_decl (n + i) d) 0 (List.rev Δ) -> Alli (fun i d => closed_decl (n + i) d) 0 (List.rev (smash_context [] Δ)). Proof. intros; apply (closed_smash_context_gen n _ []); auto. constructor. @@ -490,7 +490,7 @@ Set SimplIsCbn. Lemma closedn_mapi_rec_ext (f g : nat -> context_decl -> context_decl) (l : context) n k' : closedn_ctx k' l -> - (forall k x, n <= k -> k < length l + n -> + (forall k x, n <= k -> k < length l + n -> closed_decl (k' + #|l|) x -> f k x = g k x) -> mapi_rec f l n = mapi_rec g l n. @@ -509,7 +509,7 @@ Proof. Qed. -Lemma closed_declared_ind {Σ ind mdecl idecl} : +Lemma closed_declared_ind {Σ ind mdecl idecl} : declared_inductive Σ ind mdecl idecl -> closed_inductive_decl mdecl -> closed_inductive_body mdecl idecl. @@ -532,7 +532,7 @@ Proof. simpl in clΓ. eapply closed_decl_upwards; eauto. lia. Qed. -Arguments lift_context _ _ _ : simpl never. +Arguments lift_context _ _ _ : simpl never. Arguments subst_context _ _ _ : simpl never. Lemma closedn_ctx_lift n k k' Γ : closedn_ctx k Γ -> @@ -550,7 +550,7 @@ Proof. autorewrite with len. now rewrite Nat.add_comm (Nat.add_comm n) Nat.add_assoc. Qed. -Lemma closedn_ctx_subst k k' s Γ : +Lemma closedn_ctx_subst k k' s Γ : closedn_ctx (k + k' + #|s|) Γ -> forallb (closedn k) s -> closedn_ctx (k + k') (subst_context s k' Γ). @@ -579,8 +579,8 @@ Proof. now rewrite subst_closedn. Qed. -Lemma closedn_extended_subst_gen Γ k k' : - closedn_ctx k Γ -> +Lemma closedn_extended_subst_gen Γ k k' : + closedn_ctx k Γ -> forallb (closedn (k' + k + context_assumptions Γ)) (extended_subst Γ k'). Proof. induction Γ as [|[? [] ?] ?] in k, k' |- *; auto; rewrite ?closedn_ctx_cons /=; @@ -598,8 +598,8 @@ Proof. red. rewrite -IHΓ. f_equal. f_equal. lia. Qed. -Lemma closedn_extended_subst Γ : - closed_ctx Γ -> +Lemma closedn_extended_subst Γ : + closed_ctx Γ -> forallb (closedn (context_assumptions Γ)) (extended_subst Γ 0). Proof. intros clΓ. now apply (closedn_extended_subst_gen Γ 0 0). @@ -620,7 +620,7 @@ Proof. simpl; auto. Qed. -Lemma closed_ctx_expand_lets Γ Δ : +Lemma closed_ctx_expand_lets Γ Δ : closed_ctx (Γ ,,, Δ) -> closedn_ctx (context_assumptions Γ) (expand_lets_ctx Γ Δ). Proof. @@ -703,7 +703,7 @@ Proof. rewrite -distr_lift_subst_rec. f_equal. lia. Qed. -Lemma assumption_context_app_inv Γ Δ : assumption_context Γ -> assumption_context Δ -> +Lemma assumption_context_app_inv Γ Δ : assumption_context Γ -> assumption_context Δ -> assumption_context (Γ ++ Δ). Proof. induction 1; try constructor; auto. @@ -715,7 +715,7 @@ Proof. now simpl; rewrite andb_comm Nat.add_comm. Qed. -Lemma closedn_ctx_upwards k k' Γ : +Lemma closedn_ctx_upwards k k' Γ : closedn_ctx k Γ -> k <= k' -> closedn_ctx k' Γ. Proof. @@ -725,8 +725,8 @@ Proof. rewrite (closed_decl_upwards _ _ cla) //. lia. Qed. -Lemma closedn_expand_lets k (Γ : context) t : - closedn (k + context_assumptions Γ) (expand_lets Γ t) -> +Lemma closedn_expand_lets k (Γ : context) t : + closedn (k + context_assumptions Γ) (expand_lets Γ t) -> closedn (k + #|Γ|) t. Proof. revert k t. @@ -772,14 +772,14 @@ Proof. now rewrite Nat.add_0_r. now rewrite /= clb. rewrite -Nat.add_assoc -closedn_subst_eq. simpl. now rewrite clb. simpl; lia_f_equal. - - len'. move/andb_and => [clty clΓ]. + - len'. move/andb_and => [clty clΓ]. rewrite !expand_lets_k_vass. simpl. specialize (H Γ ltac:(len; lia) (S k)). rewrite Nat.add_assoc !Nat.add_succ_r !Nat.add_0_r. apply H. now rewrite Nat.add_1_r in clΓ. Qed. -Lemma closedn_to_extended_list_k_up k Γ k' : +Lemma closedn_to_extended_list_k_up k Γ k' : k' + #|Γ| <= k -> forallb (closedn k) (to_extended_list_k Γ k'). Proof. @@ -791,20 +791,20 @@ Proof. eapply Nat.ltb_lt. lia. Qed. -Lemma closedn_to_extended_list_k Γ k : +Lemma closedn_to_extended_list_k Γ k : forallb (closedn (k + #|Γ|)) (to_extended_list_k Γ k). Proof. now apply closedn_to_extended_list_k_up. Qed. -Lemma closedn_to_extended_list Γ : +Lemma closedn_to_extended_list Γ : forallb (closedn #|Γ|) (to_extended_list Γ). Proof. rewrite /to_extended_list. apply (closedn_to_extended_list_k _ 0). Qed. -Lemma closed_ind_predicate_context {Σ ind mdecl idecl} : +Lemma closed_ind_predicate_context {Σ ind mdecl idecl} : declared_inductive Σ ind mdecl idecl -> closed_inductive_decl mdecl -> closedn_ctx (context_assumptions mdecl.(ind_params)) (ind_predicate_context ind mdecl idecl). @@ -834,8 +834,8 @@ Proof. Qed. -Lemma closed_ind_closed_cstrs {Σ ind mdecl idecl} : - closed_inductive_decl mdecl -> +Lemma closed_ind_closed_cstrs {Σ ind mdecl idecl} : + closed_inductive_decl mdecl -> declared_inductive Σ ind mdecl idecl -> All (closed_constructor_body mdecl) (ind_ctors idecl). Proof. diff --git a/pcuic/theories/Syntax/PCUICDepth.v b/pcuic/theories/Syntax/PCUICDepth.v index 4dd36099b..f6b504342 100644 --- a/pcuic/theories/Syntax/PCUICDepth.v +++ b/pcuic/theories/Syntax/PCUICDepth.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import ssreflect Program Lia BinPos Arith.Compare_dec Bool. +From Coq Require Import ssreflect Program Lia BinPos Arith.Compare_dec Bool. From MetaCoq.Template Require Import utils LibHypsNaming. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICSize PCUICInduction. From Coq Require Import List. @@ -12,7 +12,7 @@ Import PCUICEnvTyping. Definition def_depth_gen (depth : term -> nat) (x : def term) := max (depth (dtype x)) (depth (dbody x)). -Definition list_depth_gen {A} (depth : A -> nat) := +Definition list_depth_gen {A} (depth : A -> nat) := fix list_depth (l : list A) : nat := match l with | [] => 0 @@ -27,13 +27,13 @@ Definition decl_depth_gen (depth : term -> nat) (x : context_decl) := Definition context_depth_gen (depth : term -> nat) (l : context) := list_depth_gen (decl_depth_gen depth) l. - -Definition branch_depth_gen (depth : term -> nat) p (br : branch term) := + +Definition branch_depth_gen (depth : term -> nat) p (br : branch term) := let pard := list_depth_gen depth p.(pparams) in let bctxd := context_depth_gen depth br.(bcontext) in max (pard + bctxd) (depth br.(bbody)). -Definition predicate_depth_gen (depth : term -> nat) (p : PCUICAst.predicate term) := +Definition predicate_depth_gen (depth : term -> nat) (p : PCUICAst.predicate term) := let pard := list_depth_gen depth p.(pparams) in let pctxd := context_depth_gen depth p.(pcontext) in max (pard + pctxd) (depth p.(preturn)). @@ -86,9 +86,9 @@ Proof. move/IHmfix. lia. Qed. -Lemma nth_error_depth {A} (f : A -> nat) {l : list A} {n x} : +Lemma nth_error_depth {A} (f : A -> nat) {l : list A} {n x} : nth_error l n = Some x -> - f x <= list_depth_gen f l. + f x <= list_depth_gen f l. Proof. induction l in n |- *; destruct n; simpl => //; auto. - intros [= <-]. lia. @@ -136,7 +136,7 @@ Proof. f_equal; apply aux. Qed. -Lemma All_depth {s l} k : +Lemma All_depth {s l} k : All (fun x => forall k, depth (subst s k x) <= depth x + list_depth s) l -> list_depth (map (subst s k) l) <= list_depth l + list_depth s. Proof. @@ -160,7 +160,7 @@ Proof. rewrite /predicate_depth_gen /=. eapply (All_depth k) in a. assert ((list_depth (map (subst s k) (pparams p)) + - context_depth (pcontext p)) <= + context_depth (pcontext p)) <= (list_depth (pparams p) + context_depth (pcontext p) + list_depth s)) by lia. specialize (IHt k). assert (list_depth_gen (branch_depth_gen depth (map_predicate_k id (subst s) k p)) (map_branches_k (subst s) id k l) <= @@ -169,7 +169,7 @@ Proof. destruct p0. specialize (l0 (#|bcontext x| + k)). rewrite {1 3}/branch_depth_gen /= /id. rewrite /id in IHX0. lia. } specialize (l0 (#|pcontext p| + k)). - assert ((list_depth (map (subst s k) (pparams p)) + context_depth (pcontext p)) <= + assert ((list_depth (map (subst s k) (pparams p)) + context_depth (pcontext p)) <= (list_depth (pparams p) + context_depth (pcontext p) + list_depth s)) by lia. lia. - specialize (IHt k). lia. @@ -217,7 +217,7 @@ Proof. f_equal; apply aux. Qed. -Lemma depth_subst_decl s k d : +Lemma depth_subst_decl s k d : decl_depth_gen depth (subst_decl s k d) <= decl_depth_gen depth d + list_depth s. Proof. destruct d as [na [b|] ty]; rewrite /decl_depth_gen /=. @@ -226,7 +226,7 @@ Proof. pose proof (depth_subst s k ty). lia. Qed. -Lemma depth_subst_context s k ctx : +Lemma depth_subst_context s k ctx : context_depth (subst_context s k ctx) <= context_depth ctx + list_depth s. Proof. induction ctx; simpl; try lia. @@ -296,8 +296,8 @@ Proof. simpl. specialize (H k a). specialize (IHl (S k)). lia. Qed. -Lemma context_depth_inst_case_context pars puinst pctx : - context_depth (inst_case_context pars puinst pctx) <= +Lemma context_depth_inst_case_context pars puinst pctx : + context_depth (inst_case_context pars puinst pctx) <= context_depth pctx + list_depth pars. Proof. rewrite /inst_case_context. @@ -316,14 +316,14 @@ Lemma term_forall_ctx_list_ind : (forall Γ (n : aname) (t : term), P Γ t -> forall t0 : term, P (vass n t :: Γ) t0 -> P Γ (tLambda n t t0)) -> (forall Γ (n : aname) (t : term), P Γ t -> forall t0 : term, P Γ t0 -> forall t1 : term, P (vdef n t t0 :: Γ) t1 -> P Γ (tLetIn n t t0 t1)) -> - (forall Γ (t u : term), + (forall Γ (t u : term), (forall t', depth t' < depth (tApp t u) -> P Γ t') -> P Γ t -> P Γ u -> P Γ (tApp t u)) -> (forall Γ s (u : list Level.t), P Γ (tConst s u)) -> (forall Γ (i : inductive) (u : list Level.t), P Γ (tInd i u)) -> (forall Γ (i : inductive) (n : nat) (u : list Level.t), P Γ (tConstruct i n u)) -> (forall Γ (ci : case_info) (p : predicate term) (t : term) (brs : list (branch term)), - CasePredProp P Γ p -> + CasePredProp P Γ p -> P Γ t -> CaseBrsProp p P Γ brs -> P Γ (tCase ci p t brs)) -> @@ -397,7 +397,7 @@ Proof. ++ eapply aux; auto. simpl. unfold predicate_depth_gen. lia. * eapply aux => //. simpl; lia. * red. simpl in aux. - have auxbr := fun Γ t (H : depth t <= list_depth_gen (branch_depth_gen depth p) brs) => + have auxbr := fun Γ t (H : depth t <= list_depth_gen (branch_depth_gen depth p) brs) => aux Γ t ltac:(lia). move: auxbr. clear -auxΓ. @@ -437,14 +437,14 @@ Lemma term_ind_depth_app : (forall (n : aname) (t : term), P t -> forall t0 : term, P t0 -> P (tLambda n t t0)) -> (forall (n : aname) (t : term), P t -> forall t0 : term, P t0 -> forall t1 : term, P t1 -> P (tLetIn n t t0 t1)) -> - (forall (t u : term), + (forall (t u : term), (forall t', depth t' < depth (tApp t u) -> P t') -> P t -> P u -> P (tApp t u)) -> (forall s (u : list Level.t), P (tConst s u)) -> (forall (i : inductive) (u : list Level.t), P (tInd i u)) -> (forall (i : inductive) (n : nat) (u : list Level.t), P (tConstruct i n u)) -> (forall (ci : case_info) (p : predicate term) (t : term) (brs : list (branch term)), - CasePredProp_depth P p -> + CasePredProp_depth P p -> P t -> CaseBrsProp_depth p P brs -> P (tCase ci p t brs)) -> @@ -517,7 +517,7 @@ Proof. ++ eapply aux; auto. simpl. unfold predicate_depth_gen. lia. * eapply aux => //. simpl; lia. * red. simpl in aux. - have auxbr := fun t (H : depth t <= list_depth_gen (branch_depth_gen depth p) brs) => + have auxbr := fun t (H : depth t <= list_depth_gen (branch_depth_gen depth p) brs) => aux t ltac:(lia). move: auxbr. clear -auxΓ. diff --git a/pcuic/theories/Syntax/PCUICInduction.v b/pcuic/theories/Syntax/PCUICInduction.v index 61d4cf427..96917e84b 100644 --- a/pcuic/theories/Syntax/PCUICInduction.v +++ b/pcuic/theories/Syntax/PCUICInduction.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import ssreflect Program Lia BinPos Arith.Compare_dec Bool. +From Coq Require Import ssreflect Program Lia BinPos Arith.Compare_dec Bool. From MetaCoq.Template Require Import utils LibHypsNaming. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICSize. From Coq Require Import List. @@ -9,7 +9,7 @@ From Equations.Prop Require Import Subterm. Set Asymmetric Patterns. Import PCUICEnvTyping. -(** Derive the well-founded subterm relation for terms. Not so useful +(** Derive the well-founded subterm relation for terms. Not so useful yet as it doesn't go throught lists. *) (* Derive Subterm for term. *) @@ -61,7 +61,7 @@ Proof. split. + generalize (pcontext p). fix auxc 1. - destruct l; constructor; [|apply auxc]. + destruct l; constructor; [|apply auxc]. destruct c. split. apply auxt. simpl. destruct decl_body; simpl. apply auxt. constructor. + apply auxt. @@ -72,7 +72,7 @@ Proof. split. + generalize (bcontext b). fix auxc 1. - destruct l; constructor; [|apply auxc]. + destruct l; constructor; [|apply auxc]. destruct c. split. apply auxt. simpl. destruct decl_body; simpl. apply auxt. constructor. + apply auxt. @@ -92,7 +92,7 @@ Lemma size_decompose_app_rec t L : Proof. induction t in L |- *; cbn; try lia. rewrite <- IHt1. cbn. lia. -Qed. +Qed. Lemma size_decompose_app t : size t = size (decompose_app t).1 + list_size size (decompose_app t).2. @@ -226,7 +226,7 @@ Definition mkApps_decompose_app t : From Equations Require Import Equations. -Lemma liftP_ctx_ind (P : term -> Type) (ctx : context) : +Lemma liftP_ctx_ind (P : term -> Type) (ctx : context) : (forall y, size y < context_size size ctx -> P y) -> All (ondecl P) ctx. Proof. @@ -267,20 +267,20 @@ Proof. assert (Acc (MR lt size) t) by eapply measure_wf, Wf_nat.lt_wf. induction H. rename X14 into auxt. clear H. rename x into t. move auxt at top. - + destruct t; try now repeat (match goal with H : _ |- _ => apply H; try (hnf; cbn; lia) end). - eapply X1. revert l auxt. unfold MR; cbn. fix auxt' 1. destruct l; constructor. apply auxt. hnf; cbn; lia. apply auxt'. intros. apply auxt. - hnf in *; cbn in *. lia. + hnf in *; cbn in *. lia. - rewrite -> mkApps_decompose_app. destruct decompose_app eqn:E. cbn. eapply X6. + eapply decompose_app_notApp in E. eauto. - + eapply auxt. cbn. hnf. pose proof (decompose_app_size_tApp1 t1 t2). + + eapply auxt. cbn. hnf. pose proof (decompose_app_size_tApp1 t1 t2). rewrite E in H. hnf in *; cbn in *. lia. + intros ->. rewrite /decompose_app /= in E. @@ -289,7 +289,7 @@ Proof. + induction l using rev_rec in E, auxt, t1, t2, t |- *. * constructor. * eapply All_app_inv. - 2:{ + 2:{ econstructor. eapply auxt. hnf; cbn. pose proof (decompose_app_size_tApp2 t1 t2). rewrite E in H. cbn in H. clear E. eapply Forall_All, All_app in H as [H H1]. inv H1. lia. econstructor. } @@ -297,14 +297,14 @@ Proof. -- destruct t1; try now inv Et1. pose proof E as E'. eapply IHl. - 2:{ + 2:{ eapply decompose_app_inv in E. rewrite mkApps_app in E. cbn in E. noconf E. rewrite -> H. rewrite -> decompose_app_mkApps. reflexivity. eapply decompose_app_notApp in E'. now rewrite E'. } eapply decompose_app_inv in E. rewrite mkApps_app in E. - cbn in E. noconf E. + cbn in E. noconf E. intros. eapply auxt. red. red in H0. cbn in *. lia. -- destruct l. @@ -327,25 +327,25 @@ Proof. destruct l; constructor. split; [|apply auxt; hnf; cbn; lia]. + apply liftP_ctx_ind; intros. apply auxt; red; simpl; lia. + apply auxt'. intros. apply auxt. - hnf in *; cbn in *. lia. + hnf in *; cbn in *. lia. - eapply X12; [apply auxt; hnf; cbn; lia.. | ]. rename mfix into l. revert l auxt. unfold MR; cbn. fix auxt' 1. destruct l; constructor. split. apply auxt. hnf; cbn. unfold def_size. lia. - apply auxt. hnf; cbn. unfold def_size. lia. + apply auxt. hnf; cbn. unfold def_size. lia. apply auxt'. intros. apply auxt. - hnf in *; cbn in *. unfold mfixpoint_size, def_size in *. lia. + hnf in *; cbn in *. unfold mfixpoint_size, def_size in *. lia. - eapply X13; [apply auxt; hnf; cbn; lia.. | ]. rename mfix into l. revert l auxt. unfold MR; cbn. fix auxt' 1. destruct l; constructor. split. apply auxt. hnf; cbn. unfold def_size. lia. - apply auxt. hnf; cbn. unfold def_size. lia. + apply auxt. hnf; cbn. unfold def_size. lia. apply auxt'. intros. apply auxt. - hnf in *; cbn in *. unfold mfixpoint_size, def_size in *. lia. + hnf in *; cbn in *. unfold mfixpoint_size, def_size in *. lia. Defined. -Lemma liftP_ctx (P : term -> Type) : +Lemma liftP_ctx (P : term -> Type) : (forall t, P t) -> (forall ctx, All (ondecl P) ctx). Proof. @@ -357,7 +357,7 @@ Proof. Qed. Lemma ctx_length_ind (P : context -> Type) (p0 : P []) - (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (d :: Γ)) + (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (d :: Γ)) Γ : P Γ. Proof. generalize (le_n #|Γ|). @@ -371,7 +371,7 @@ Proof. Qed. Lemma ctx_length_rev_ind (P : context -> Type) (p0 : P []) - (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (Γ ++ [d])) + (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (Γ ++ [d])) Γ : P Γ. Proof. generalize (le_n #|Γ|). @@ -456,7 +456,7 @@ Definition CasePredProp (P : context -> term -> Type) Γ (p : predicate term) := P (Γ ,,, inst_case_context p.(pparams) p.(puinst) p.(pcontext)) p.(preturn). Definition CaseBrsProp p P Γ (brs : list (branch term)) := - All (fun x : branch term => onctx_rel P Γ (bcontext x) * P (Γ ,,, inst_case_context p.(pparams) p.(puinst) + All (fun x : branch term => onctx_rel P Γ (bcontext x) * P (Γ ,,, inst_case_context p.(pparams) p.(puinst) x.(bcontext)) (bbody x)) brs. Lemma term_forall_ctx_list_ind : @@ -474,7 +474,7 @@ Lemma term_forall_ctx_list_ind : (forall Γ (i : inductive) (u : list Level.t), P Γ (tInd i u)) -> (forall Γ (i : inductive) (n : nat) (u : list Level.t), P Γ (tConstruct i n u)) -> (forall Γ (ci : case_info) (p : predicate term) (t : term) (brs : list (branch term)), - CasePredProp P Γ p -> + CasePredProp P Γ p -> P Γ t -> CaseBrsProp p P Γ brs -> P Γ (tCase ci p t brs)) -> @@ -546,7 +546,7 @@ Proof. ++ eapply aux; auto. simpl. unfold predicate_size. lia. * eapply aux => //. simpl; lia. * red. simpl in aux. - have auxbr := fun Γ t (H : size t <= list_size (branch_size size) brs) => + have auxbr := fun Γ t (H : size t <= list_size (branch_size size) brs) => aux Γ t ltac:(lia). move: auxbr. clear -auxΓ. @@ -555,7 +555,7 @@ Proof. + split. eapply auxΓ. simpl. unfold branch_size. lia. eapply auxbr. unfold branch_size. lia. + eapply IHbrs. intros. apply auxΓ. simpl in *. lia. - intros. apply auxbr. simpl. lia. + intros. apply auxbr. simpl. lia. - eapply X12; try (apply aux; red; simpl; lia). apply auxΓ => //. simpl. specialize (H mfix). lia. red. apply All_pair. split; apply auxl; simpl; auto. @@ -566,8 +566,8 @@ Proof. Defined. (** This induction principle gives a general induction hypothesis for applications, - allowing to apply the induction to their head or any smaller term. *) -Lemma term_ind_size_app : + allowing to apply the induction to their head or any smaller term. *) +Lemma term_ind_size_app : forall (P : term -> Type), (forall (n : nat), P (tRel n)) -> (forall (i : ident), P (tVar i)) -> @@ -626,7 +626,7 @@ Proof. try (apply aux; cbn; lia). exact tt. apply IHl; intros. apply aux; simpl; lia. + apply aux; simpl. unfold predicate_size. lia. - + red. + + red. revert aux; simpl. clear. induction hh1; simpl; constructor; auto. @@ -638,7 +638,7 @@ Proof. apply IHl; intros. apply aux; simpl; lia. apply aux. lia. apply IHhh1. intros. apply aux. lia. - + * eapply X12; try (apply aux; red; simpl; lia). red. apply All_pair. split; apply auxl; simpl; auto. diff --git a/pcuic/theories/Syntax/PCUICInstDef.v b/pcuic/theories/Syntax/PCUICInstDef.v index 44b579724..95564c2e8 100644 --- a/pcuic/theories/Syntax/PCUICInstDef.v +++ b/pcuic/theories/Syntax/PCUICInstDef.v @@ -2,7 +2,7 @@ From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction - PCUICLiftSubst PCUICUnivSubst + PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICEquality PCUICOnFreeVars PCUICSigmaCalculus PCUICRenameDef. @@ -56,8 +56,8 @@ Definition usubst (Γ : context) σ (Δ : context) := (* Untyped substitution for untyped reduction / cumulativity *) Definition closed_subst (Γ : context) σ (Δ : context) := - is_closed_context Δ × - (forall x decl, nth_error Γ x = Some decl -> is_open_term Δ (σ x)) × + is_closed_context Δ × + (forall x decl, nth_error Γ x = Some decl -> is_open_term Δ (σ x)) × usubst Γ σ Δ. (* Well-typedness of a substitution *) @@ -66,7 +66,7 @@ Definition well_subst {cf} Σ (Γ : context) σ (Δ : context) := (forall x decl, nth_error Γ x = Some decl -> Σ ;;; Δ |- σ x : ((lift0 (S x)) (decl_type decl)).[ σ ]) × - usubst Γ σ Δ. + usubst Γ σ Δ. Notation "Σ ;;; Δ ⊢ σ : Γ" := (well_subst Σ Γ σ Δ) (at level 50, Δ, σ, Γ at next level). diff --git a/pcuic/theories/Syntax/PCUICLiftSubst.v b/pcuic/theories/Syntax/PCUICLiftSubst.v index c1b1929b6..2d489c850 100644 --- a/pcuic/theories/Syntax/PCUICLiftSubst.v +++ b/pcuic/theories/Syntax/PCUICLiftSubst.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -Require Import ssreflect Morphisms. +Require Import ssreflect Morphisms. From MetaCoq.Template Require Import utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction. Import Nat. @@ -10,7 +10,7 @@ Import Nat. Derive Signature for Peano.le. -(** Assumptions contexts do not contain let-ins. *) +(** Assumptions contexts do not contain let-ins. *) Inductive assumption_context : context -> Prop := | assumption_context_nil : assumption_context [] @@ -310,7 +310,7 @@ Proof. elim t using term_forall_list_ind; intros; try easy; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?map_predicate_map_predicate, ?map_branch_map_branch; - simpl closed in *; + simpl closed in *; unfold test_predicate_k, test_def, test_branch_k in *; try solve [simpl lift; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. - rewrite lift_rel_lt; auto. @@ -412,7 +412,7 @@ Proof. rewrite -> permute_lift. f_equal; lia. lia. Qed. -Definition fix_context_gen k mfix := +Definition fix_context_gen k mfix := List.rev (mapi_rec (fun (i : nat) (d : def term) => vass (dname d) (lift0 i (dtype d))) mfix k). Lemma lift_decl0 k d : map_decl (lift 0 k) d = d. @@ -492,13 +492,13 @@ Qed. Lemma simpl_subst' : forall N M n p k, k = List.length N -> p <= n -> subst N p (lift0 (k + n) M) = lift0 n M. -Proof. +Proof. intros. subst k. rewrite simpl_subst_rec; auto. - + now rewrite Nat.add_0_r. + + now rewrite Nat.add_0_r. + lia. Qed. -Lemma subst_subst_lift (s s' : list term) n t : n = #|s| + #|s'| -> +Lemma subst_subst_lift (s s' : list term) n t : n = #|s| + #|s'| -> subst0 s (subst0 s' (lift0 n t)) = t. Proof. intros ->. rewrite Nat.add_comm simpl_subst' //; try lia. @@ -509,7 +509,7 @@ Lemma map_subst_lift_id s l : map (subst0 s ∘ lift0 #|s|) l = l. Proof. induction l; simpl; auto. rewrite -{1}(Nat.add_0_r #|s|) simpl_subst'; auto. - now rewrite lift0_id IHl. + now rewrite lift0_id IHl. Qed. Lemma map_subst_lift_id_eq s l k : k = #|s| -> map (subst0 s ∘ lift0 k) l = l. @@ -523,7 +523,7 @@ Proof. apply map_ext => x. now apply simpl_subst'. Qed. -Lemma map_subst_subst_lift_lift (s s' : list term) k k' l : k + k' = #|s| + #|s'| -> +Lemma map_subst_subst_lift_lift (s s' : list term) k k' l : k + k' = #|s| + #|s'| -> map (fun t => subst0 s (subst0 s' (lift k k' (lift0 k' t)))) l = l. Proof. intros H. eapply All_map_id. eapply All_refl => x. @@ -606,7 +606,7 @@ Proof. rewrite distr_lift_subst_rec; f_equal. f_equal. lia. Qed. -Lemma skipn_subst_context n s k Γ : skipn n (subst_context s k Γ) = +Lemma skipn_subst_context n s k Γ : skipn n (subst_context s k Γ) = subst_context s k (skipn n Γ). Proof. rewrite !subst_context_alt. @@ -614,7 +614,7 @@ Proof. apply mapi_rec_ext. intros. f_equal. rewrite List.skipn_length. lia. Qed. - + Lemma lift_extended_subst (Γ : context) k : extended_subst Γ k = map (lift0 k) (extended_subst Γ 0). Proof. @@ -660,14 +660,14 @@ Proof. erewrite (commut_lift_subst_rec); lia_f_equal. Qed. -Lemma extended_subst_app Γ Γ' : - extended_subst (Γ ++ Γ') 0 = +Lemma extended_subst_app Γ Γ' : + extended_subst (Γ ++ Γ') 0 = extended_subst (subst_context (extended_subst Γ' 0) 0 - (lift_context (context_assumptions Γ') #|Γ'| Γ)) 0 ++ + (lift_context (context_assumptions Γ') #|Γ'| Γ)) 0 ++ extended_subst Γ' (context_assumptions Γ). Proof. induction Γ as [|[na [b|] ty] Γ] in |- *; simpl; auto. - - autorewrite with len. + - autorewrite with len. rewrite IHΓ. simpl. rewrite app_comm_cons. f_equal. erewrite subst_app_simpl'. @@ -821,8 +821,8 @@ Qed. (** Standard substitution lemma for a context with no lets. *) Inductive nth_error_app_spec {A} (l l' : list A) (n : nat) : option A -> Type := -| nth_error_app_spec_left x : - nth_error l n = Some x -> +| nth_error_app_spec_left x : + nth_error l n = Some x -> n < #|l| -> nth_error_app_spec l l' n (Some x) | nth_error_app_spec_right x : @@ -849,7 +849,7 @@ Proof. len. intros. constructor. lia. Qed. -Lemma nth_error_app_context (Γ Δ : context) (n : nat) : +Lemma nth_error_app_context (Γ Δ : context) (n : nat) : nth_error_app_spec Δ Γ n (nth_error (Γ ,,, Δ) n). Proof. apply nth_error_appP. diff --git a/pcuic/theories/Syntax/PCUICNamelessDef.v b/pcuic/theories/Syntax/PCUICNamelessDef.v index 26e45d4c9..54da4bbfa 100644 --- a/pcuic/theories/Syntax/PCUICNamelessDef.v +++ b/pcuic/theories/Syntax/PCUICNamelessDef.v @@ -11,8 +11,8 @@ Implicit Types cf : checker_flags. (** Typing / conversion does not rely on name annotations of binders. - We prove this by constructing a type-preserving translation to - terms where all binders are anonymous. An alternative would be to + We prove this by constructing a type-preserving translation to + terms where all binders are anonymous. An alternative would be to be parametrically polymorphic everywhere on the binder name type. This would allow to add implicit information too. *) @@ -46,9 +46,9 @@ Fixpoint nameless (t : term) : bool := | tInd i u => true | tConstruct i n u => true | tCase ci p c brs => - forallb nameless p.(pparams) && + forallb nameless p.(pparams) && forallb (nameless_decl nameless) p.(pcontext) && - nameless p.(preturn) && nameless c && + nameless p.(preturn) && nameless c && forallb (fun b => forallb (nameless_decl nameless) b.(bcontext) && nameless b.(bbody)) brs | tProj p c => nameless c | tFix mfix idx => @@ -62,7 +62,7 @@ Fixpoint nameless (t : term) : bool := Notation nameless_ctx := (forallb (nameless_decl nameless)). -Definition anonymize (b : binder_annot name) : binder_annot name := +Definition anonymize (b : binder_annot name) : binder_annot name := map_binder_annot (fun _ => nAnon) b. Definition map_def_anon {A B} (tyf bodyf : A -> B) (d : def A) := {| @@ -112,22 +112,22 @@ Definition nlctx (Γ : context) : context := map (map_decl_anon nl) Γ. Definition nl_constant_body c := - Build_constant_body + Build_constant_body (nl c.(cst_type)) (option_map nl c.(cst_body)) c.(cst_universes) c.(cst_relevance). Definition nl_constructor_body c := - {| cstr_name := c.(cstr_name) ; + {| cstr_name := c.(cstr_name) ; cstr_args := nlctx c.(cstr_args); cstr_indices := map nl c.(cstr_indices); cstr_type := nl c.(cstr_type); cstr_arity := c.(cstr_arity) |}. Definition nl_projection_body p := - {| proj_name := p.(proj_name) ; + {| proj_name := p.(proj_name) ; proj_type := nl p.(proj_type); proj_relevance := p.(proj_relevance) |}. - + Definition nl_one_inductive_body o := Build_one_inductive_body o.(ind_name) @@ -157,10 +157,10 @@ Definition nl_global_declarations (Σ : global_declarations) : global_declaratio (map (on_snd nl_global_decl) Σ). Definition nl_global_env (Σ : global_env) : global_env := - {| universes := Σ.(universes); + {| universes := Σ.(universes); declarations := nl_global_declarations Σ.(declarations); retroknowledge := Σ.(retroknowledge) |}. - + Definition nlg (Σ : global_env_ext) : global_env_ext := let '(Σ, φ) := Σ in (nl_global_env Σ, φ). diff --git a/pcuic/theories/Syntax/PCUICOnFreeVars.v b/pcuic/theories/Syntax/PCUICOnFreeVars.v index 8074815a7..43bec1efb 100644 --- a/pcuic/theories/Syntax/PCUICOnFreeVars.v +++ b/pcuic/theories/Syntax/PCUICOnFreeVars.v @@ -3,7 +3,7 @@ From Coq Require Import Morphisms. Require Import ssreflect ssrfun ssrbool. From MetaCoq.Template Require Import config utils MCPred. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction - PCUICLiftSubst PCUICUnivSubst + PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICSigmaCalculus PCUICClosed. Require Import Equations.Prop.DepElim. @@ -28,11 +28,11 @@ Definition shiftnP k p i := #[global] Instance shiftnP_ext k : Proper (`=1` ==> `=1`) (shiftnP k). -Proof. intros f g Hfg i. now rewrite /shiftnP Hfg. Qed. +Proof. intros f g Hfg i. now rewrite /shiftnP Hfg. Qed. Lemma shiftnP0 P : shiftnP 0 P =1 P. Proof. rewrite /shiftnP. intros i; rewrite Nat.sub_0_r //. Qed. - + Lemma shiftnP_add n k P : shiftnP n (shiftnP k P) =1 shiftnP (n + k) P. Proof. rewrite /shiftnP. intros i; repeat nat_compare_specs => // /=. lia_f_equal. Qed. @@ -55,7 +55,7 @@ Qed. Lemma shiftnP_S P n : shiftnP (S n) P =1 shiftnP 1 (shiftnP n P). Proof. now rewrite (shiftnP_add 1). Qed. -Definition closedP (n : nat) (P : nat -> bool) := +Definition closedP (n : nat) (P : nat -> bool) := fun i => if i //. Qed. - + Fixpoint on_free_vars (p : nat -> bool) (t : term) : bool := match t with | tRel i => p i @@ -80,7 +80,7 @@ Fixpoint on_free_vars (p : nat -> bool) (t : term) : bool := on_free_vars (shiftnP #|pred.(pcontext)| p) pred.(preturn), test_context_k (fun k => on_free_vars (closedP k xpredT)) #|pred.(pparams)| pred.(pcontext), on_free_vars p c & - forallb (fun br => + forallb (fun br => test_context_k (fun k => on_free_vars (closedP k xpredT)) #|pred.(pparams)| br.(bcontext) && on_free_vars (shiftnP #|br.(bcontext)| p) br.(bbody)) brs] | tProj _ c => on_free_vars p c @@ -90,7 +90,7 @@ Fixpoint on_free_vars (p : nat -> bool) (t : term) : bool := | tPrim _ => true end. -Lemma on_free_vars_ext (p q : nat -> bool) t : +Lemma on_free_vars_ext (p q : nat -> bool) t : p =1 q -> on_free_vars p t = on_free_vars q t. Proof. @@ -138,7 +138,7 @@ Hint Rewrite test_context_k_ctx : map. Proof. revert t. induction t using PCUICInduction.term_forall_list_ind; simpl => //; solve_all. - all:try (rtoProp; now rewrite ?shiftnP_xpredT ?IHt1 ?IHt2 ?IHt3; eauto 2; + all:try (rtoProp; now rewrite ?shiftnP_xpredT ?IHt1 ?IHt2 ?IHt3; eauto 2; try rtoProp; solve_all). - rtoProp. setoid_rewrite shiftnP_xpredT. rewrite test_context_k_ctx. @@ -165,7 +165,7 @@ Qed. *) Lemma on_free_vars_impl (p q : nat -> bool) t : (forall i, p i -> q i) -> - on_free_vars p t -> + on_free_vars p t -> on_free_vars q t. Proof. unfold pointwise_relation, Basics.impl. @@ -193,7 +193,7 @@ Proof. - unfold test_def. solve_all. rewrite shiftnP_closedP shiftnP_xpredT. now len in b. - - unfold test_def; solve_all. + - unfold test_def; solve_all. rewrite shiftnP_closedP shiftnP_xpredT. now len in b. Qed. @@ -247,7 +247,7 @@ Definition on_free_vars_ctx P ctx := Instance on_free_vars_ctx_proper : Proper (`=1` ==> `=1`) on_free_vars_ctx. Proof. rewrite /on_free_vars_ctx => f g Hfg x. - now setoid_rewrite Hfg. + now setoid_rewrite Hfg. Qed. Notation is_open_term Γ := (on_free_vars (shiftnP #|Γ| xpred0)). @@ -255,8 +255,8 @@ Notation is_open_decl Γ := (on_free_vars_decl (shiftnP #|Γ| xpred0)). Notation is_closed_context := (on_free_vars_ctx xpred0). -Lemma on_free_vars_decl_impl (p q : nat -> bool) d : - (forall i, p i -> q i) -> +Lemma on_free_vars_decl_impl (p q : nat -> bool) d : + (forall i, p i -> q i) -> on_free_vars_decl p d -> on_free_vars_decl q d. Proof. intros hpi. @@ -264,8 +264,8 @@ Proof. now apply on_free_vars_impl. Qed. -Lemma on_free_vars_ctx_impl (p q : nat -> bool) ctx : - (forall i, p i -> q i) -> +Lemma on_free_vars_ctx_impl (p q : nat -> bool) ctx : + (forall i, p i -> q i) -> on_free_vars_ctx p ctx -> on_free_vars_ctx q ctx. Proof. intros hpi. @@ -292,7 +292,7 @@ Proof. Qed. Lemma closedP_shiftnP (n : nat) : closedP n xpredT =1 shiftnP n xpred0. -Proof. +Proof. rewrite /closedP /shiftnP => i. destruct Nat.ltb => //. Qed. @@ -304,7 +304,7 @@ Proof. nat_compare_specs => //. Qed. -Lemma closedn_ctx_on_free_vars_shift {n ctx P} : +Lemma closedn_ctx_on_free_vars_shift {n ctx P} : closedn_ctx n ctx -> on_free_vars_ctx (shiftnP n P) ctx. Proof. @@ -327,16 +327,16 @@ Qed. Definition nocc_betweenp k n i := (i (i bool) := - fun i => if i bool) := + fun i => if i /= //. + repeat nat_compare_specs => /= //. lia_f_equal. Qed. -Lemma on_free_vars_lift (p : nat -> bool) n k t : +Lemma on_free_vars_lift (p : nat -> bool) n k t : on_free_vars (strengthenP k n p) (lift n k t) = on_free_vars p t. Proof. intros. revert t n k p. @@ -376,13 +376,13 @@ Qed. Definition on_free_vars_terms p s := forallb (on_free_vars p) s. - + Definition substP (k : nat) n (q p : nat -> bool) : nat -> bool := - fun i => + fun i => if i bool) s k t : +Lemma on_free_vars_subst_gen (p q : nat -> bool) s k t : on_free_vars_terms q s -> on_free_vars p t -> on_free_vars (substP k #|s| q p) (subst s k t). @@ -402,14 +402,14 @@ Proof. revert t p k. induction t using PCUICInduction.term_forall_list_ind; simpl => //; intros; simpl. - all:try (rtoProp; rewrite ?shiftnP_substP; now rewrite ?IHt1 ?IHt2 ?IHt3). + all:try (rtoProp; rewrite ?shiftnP_substP; now rewrite ?IHt1 ?IHt2 ?IHt3). - intros. destruct (Nat.leb_spec k n). * destruct nth_error eqn:eq. + unfold on_free_vars_terms in *. toAll. pose proof (nth_error_Some_length eq). eapply nth_error_all in eq; eauto. simpl in eq. rewrite /substP. - eapply on_free_vars_impl. + eapply on_free_vars_impl. 2:now rewrite -> on_free_vars_lift. rewrite /strengthenP. simpl. intros i. nat_compare_specs => //. @@ -434,7 +434,7 @@ Qed. Lemma rshiftk_S x f : S (rshiftk x f) = rshiftk (S x) f. Proof. reflexivity. Qed. -Lemma substP_shiftnP n p : +Lemma substP_shiftnP n p : substP 0 n p (shiftnP n p) =1 p. Proof. intros i; rewrite /shiftnP /substP /= /strengthenP /=. @@ -443,7 +443,7 @@ Proof. now rewrite Nat.sub_0_r orb_diag. Qed. -Lemma on_free_vars_subst (p : nat -> bool) s t : +Lemma on_free_vars_subst (p : nat -> bool) s t : forallb (on_free_vars p) s -> on_free_vars (shiftnP #|s| p) t -> on_free_vars p (subst s 0 t). @@ -456,7 +456,7 @@ Proof. - apply ht. Qed. -Lemma on_free_vars_subst1 (p : nat -> bool) s t : +Lemma on_free_vars_subst1 (p : nat -> bool) s t : on_free_vars p s -> on_free_vars (shiftnP 1 p) t -> on_free_vars p (subst1 s 0 t). @@ -478,7 +478,7 @@ Instance addnP_proper n : Proper (`=1` ==> Logic.eq ==> Logic.eq) (addnP n). Proof. intros i f g Hfg; now rewrite /addnP. Qed. - + #[global] Instance addnP_proper_pointwise : Proper (Logic.eq ==> `=1` ==> `=1`) addnP. Proof. @@ -510,7 +510,7 @@ Instance on_ctx_free_vars_proper : Proper (`=1` ==> eq ==> eq) on_ctx_free_vars. Proof. rewrite /on_ctx_free_vars => f g Hfg x y <-. apply alli_ext => k. - now setoid_rewrite Hfg. + now setoid_rewrite Hfg. Qed. #[global] @@ -518,7 +518,7 @@ Instance on_ctx_free_vars_proper_pointwise : Proper (`=1` ==> `=1`) on_ctx_free_ Proof. rewrite /on_ctx_free_vars => f g Hfg x. apply alli_ext => k. - now setoid_rewrite Hfg. + now setoid_rewrite Hfg. Qed. Lemma nth_error_on_free_vars_ctx P n ctx i d : @@ -566,7 +566,7 @@ Proof. now replace (i' - i + i) with i' by lia. Qed. -Lemma on_free_vars_mkApps p f args : +Lemma on_free_vars_mkApps p f args : on_free_vars p (mkApps f args) = on_free_vars p f && forallb (on_free_vars p) args. Proof. induction args in f |- * => /=. @@ -574,10 +574,10 @@ Proof. - now rewrite IHargs /= andb_assoc. Qed. -Lemma extended_subst_shiftn p ctx n k : - forallb (on_free_vars (strengthenP 0 n (shiftnP (k + context_assumptions ctx) p))) +Lemma extended_subst_shiftn p ctx n k : + forallb (on_free_vars (strengthenP 0 n (shiftnP (k + context_assumptions ctx) p))) (extended_subst ctx (n + k)) = - forallb (on_free_vars (shiftnP (k + (context_assumptions ctx)) p)) + forallb (on_free_vars (shiftnP (k + (context_assumptions ctx)) p)) (extended_subst ctx k). Proof. rewrite lift_extended_subst' forallb_map. @@ -585,7 +585,7 @@ Proof. rewrite -(on_free_vars_lift _ n 0 t) //. Qed. -Lemma extended_subst_shiftn_aboveP p ctx n k : +Lemma extended_subst_shiftn_aboveP p ctx n k : forallb (on_free_vars (aboveP n p)) (extended_subst ctx (n + k)) = forallb (on_free_vars (addnP n p)) (extended_subst ctx k). Proof. @@ -594,8 +594,8 @@ Proof. rewrite -(on_free_vars_lift0_above) //. Qed. -Lemma extended_subst_shiftn_impl p ctx n k : - forallb (on_free_vars (shiftnP (k + (context_assumptions ctx)) p)) +Lemma extended_subst_shiftn_impl p ctx n k : + forallb (on_free_vars (shiftnP (k + (context_assumptions ctx)) p)) (extended_subst ctx k) -> forallb (on_free_vars (shiftnP (n + k + context_assumptions ctx) p)) (extended_subst ctx (n + k)). @@ -622,7 +622,7 @@ Proof. Qed. Lemma on_free_vars_mkProd_or_LetIn P d t : - on_free_vars P (mkProd_or_LetIn d t) = + on_free_vars P (mkProd_or_LetIn d t) = on_free_vars_decl P d && on_free_vars (shiftnP 1 P) t. Proof. destruct d as [na [b|] ty]; rewrite /mkProd_or_LetIn /on_free_vars_decl /test_decl /= @@ -644,20 +644,20 @@ Qed. Definition on_free_vars_ctx_k P n ctx := alli (fun k => (on_free_vars_decl (shiftnP k P))) n (List.rev ctx). -Definition predA {A} (p q : pred A) : simpl_pred A := +Definition predA {A} (p q : pred A) : simpl_pred A := [pred i | p i ==> q i]. -Definition eq_simpl_pred {A} (x y : simpl_pred A) := +Definition eq_simpl_pred {A} (x y : simpl_pred A) := `=1` x y. - + #[global] Instance implP_Proper {A} : Proper (`=1` ==> `=1` ==> eq_simpl_pred) (@predA A). Proof. intros f g Hfg f' g' Hfg' i; rewrite /predA /=. now rewrite Hfg Hfg'. Qed. - -Lemma on_free_vars_implP p q t : + +Lemma on_free_vars_implP p q t : predA p q =1 xpredT -> on_free_vars p t -> on_free_vars q t. Proof. @@ -666,7 +666,7 @@ Proof. intros i hp. specialize (Hp i). now rewrite /= hp in Hp. Qed. -Definition shiftnP_predU n p q : +Definition shiftnP_predU n p q : shiftnP n (predU p q) =1 predU (shiftnP n p) (shiftnP n q). Proof. intros i. @@ -707,18 +707,18 @@ Proof. rewrite /predU /= => ->; rewrite orb_true_r //. Qed. -(** We need a disjunction here as the substitution can be made of - expanded lets (properly lifted) or just the variables of +(** We need a disjunction here as the substitution can be made of + expanded lets (properly lifted) or just the variables of [ctx] (lifted by [k]). - + The proof could certainly be simplified using a more high-level handling of - free-variables predicate, which form a simple classical algebra. + free-variables predicate, which form a simple classical algebra. To investigate: does ssr's library support this? *) Lemma on_free_vars_extended_subst p k ctx : on_free_vars_ctx_k p k ctx -> - forallb (on_free_vars - (predU (strengthenP 0 (context_assumptions ctx + k) (shiftnP k p)) + forallb (on_free_vars + (predU (strengthenP 0 (context_assumptions ctx + k) (shiftnP k p)) (occ_betweenP k (context_assumptions ctx)))) (extended_subst ctx k). Proof. @@ -755,10 +755,10 @@ Proof. rewrite !orb_false_r. replace (i + 1 - S (context_assumptions ctx + k) - k) with (i - (context_assumptions ctx + k) - k) by lia. - rewrite implybE. destruct p; auto. + rewrite implybE. destruct p; auto. Qed. -Lemma on_free_vars_expand_lets_k P Γ n t : +Lemma on_free_vars_expand_lets_k P Γ n t : n = context_assumptions Γ -> on_free_vars_ctx P Γ -> on_free_vars (shiftnP #|Γ| P) t -> @@ -780,7 +780,7 @@ Proof. now rewrite orb_diag. Qed. -Lemma on_free_vars_terms_inds P ind puinst bodies : +Lemma on_free_vars_terms_inds P ind puinst bodies : on_free_vars_terms P (inds ind puinst bodies). Proof. rewrite /inds. @@ -823,7 +823,7 @@ Proof. Qed. -Lemma on_free_vars_to_extended_list P ctx : +Lemma on_free_vars_to_extended_list P ctx : forallb (on_free_vars (shiftnP #|ctx| P)) (to_extended_list ctx). Proof. rewrite /to_extended_list /to_extended_list_k. @@ -887,7 +887,7 @@ Lemma on_free_vars_unfold_fix P mfix idx narg fn : on_free_vars P (tFix mfix idx) -> on_free_vars P fn. Proof. - rewrite /unfold_fix. + rewrite /unfold_fix. destruct nth_error eqn:hnth => // [=] _ <- /=. intros hmfix; generalize hmfix. move/forallb_All/(nth_error_all hnth) => /andP [] _ Hbody. @@ -910,7 +910,7 @@ Lemma on_free_vars_unfold_cofix P mfix idx narg fn : on_free_vars P (tCoFix mfix idx) -> on_free_vars P fn. Proof. - rewrite /unfold_cofix. + rewrite /unfold_cofix. destruct nth_error eqn:hnth => // [=] _ <- /=. intros hmfix; generalize hmfix. move/forallb_All/(nth_error_all hnth) => /andP [] _ Hbody. @@ -924,13 +924,13 @@ Proof. lia. Qed. Lemma addnP_shiftnP_comm n (P : nat -> bool) : P 0 -> addnP 1 (shiftnP n P) =1 shiftnP n (addnP 1 P). Proof. intros p0 i; rewrite /addnP /shiftnP /=. - repeat nat_compare_specs => /= //. + repeat nat_compare_specs => /= //. - now rewrite (lenm_eq H0). - lia_f_equal. Qed. -Lemma on_ctx_free_vars_concat P Γ Δ : - on_ctx_free_vars (shiftnP #|Δ| P) (Γ ,,, Δ) = +Lemma on_ctx_free_vars_concat P Γ Δ : + on_ctx_free_vars (shiftnP #|Δ| P) (Γ ,,, Δ) = on_ctx_free_vars P Γ && on_ctx_free_vars (shiftnP #|Δ| P) Δ. Proof. rewrite /on_ctx_free_vars alli_app. @@ -964,7 +964,7 @@ Proof. rewrite /closedP /xpredT. auto. Qed. -Lemma on_free_vars_ctx_on_ctx_free_vars {P Γ} : +Lemma on_free_vars_ctx_on_ctx_free_vars {P Γ} : on_ctx_free_vars (PCUICOnFreeVars.shiftnP #|Γ| P) Γ = on_free_vars_ctx P Γ. Proof. @@ -979,7 +979,7 @@ Qed. (* Lemma on_ctx_free_vars_impl {P Q Γ} *) -Lemma on_free_vars_ctx_on_ctx_free_vars_xpredT {P Γ} : +Lemma on_free_vars_ctx_on_ctx_free_vars_xpredT {P Γ} : on_free_vars_ctx P Γ -> on_ctx_free_vars xpredT Γ. Proof. @@ -995,7 +995,7 @@ Proof. apply on_free_vars_ctx_on_ctx_free_vars. Qed. -Lemma on_free_vars_fix_context P mfix : +Lemma on_free_vars_fix_context P mfix : All (fun x : def term => test_def (on_free_vars P) (on_free_vars (shiftnP #|mfix| P)) x) mfix -> @@ -1074,7 +1074,7 @@ Lemma on_free_vars_case_predicate_context {cf} {Σ} {wfΣ : wf Σ} {P ci mdecl i intros. simpl. eapply on_free_vars_lift0. now rewrite addnP_shiftnP. Qed. - + Lemma on_free_vars_case_branch_context {cf} {Σ} {wfΣ : wf Σ} {P ci i mdecl idecl p br cdecl} : let brctx := case_branch_context ci mdecl p (forget_types (bcontext br)) cdecl in declared_constructor Σ (ci, i) mdecl idecl cdecl -> @@ -1140,8 +1140,8 @@ Proof. intros k. rewrite Nat.add_comm. apply closedP_shiftnP_impl. Qed. - -Lemma on_ctx_free_vars_snoc {P Γ d} : + +Lemma on_ctx_free_vars_snoc {P Γ d} : on_ctx_free_vars (shiftnP 1 P) (Γ ,, d) = on_ctx_free_vars P Γ && on_free_vars_decl P d. Proof. @@ -1160,8 +1160,8 @@ Proof. now setoid_rewrite shiftnP_closedP; setoid_rewrite shiftnP_xpredT; setoid_rewrite Nat.add_comm at 1. Qed. -Lemma inv_on_free_vars_decl {P d} : - on_free_vars_decl P d -> +Lemma inv_on_free_vars_decl {P d} : + on_free_vars_decl P d -> match d with | {| decl_body := None; decl_type := t |} => on_free_vars P t | {| decl_body := Some b; decl_type := t |} => on_free_vars P b /\ on_free_vars P t @@ -1175,11 +1175,11 @@ Ltac inv_on_free_vars := repeat match goal with | [ H : is_true (on_free_vars_decl _ (vass _ _)) |- _ ] => apply inv_on_free_vars_decl in H; cbn in H | [ H : is_true (on_free_vars_decl _ (vdef _ _ _)) |- _ ] => apply inv_on_free_vars_decl in H as [] - | [ H : is_true (_ && _) |- _ ] => + | [ H : is_true (_ && _) |- _ ] => move/andP: H => []; intros - | [ H : is_true (on_free_vars ?P ?t) |- _ ] => + | [ H : is_true (on_free_vars ?P ?t) |- _ ] => progress (cbn in H || rewrite on_free_vars_mkApps in H); - (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || + (move/and5P: H => [] || move/and4P: H => [] || move/and3P: H => [] || move/andP: H => [] || eapply forallb_All in H); intros | [ H : is_true (test_def (on_free_vars ?P) ?Q ?x) |- _ ] => move/andP: H => []; rewrite ?shiftnP_xpredT; intros @@ -1205,7 +1205,7 @@ Qed. #[global] Hint Resolve on_free_vars_vass on_free_vars_vdef : fvs. -Lemma onctx_All_fold P Q (Γ : context) : +Lemma onctx_All_fold P Q (Γ : context) : onctx P Γ -> (forall Γ x, All_fold Q Γ -> ondecl P x -> Q Γ x) -> All_fold Q Γ. @@ -1213,7 +1213,7 @@ Proof. intros o H; induction o; constructor; auto. Qed. -Lemma substP_shiftnP_gen k n p : +Lemma substP_shiftnP_gen k n p : substP k n p (shiftnP (k + n) p) =1 shiftnP k p. Proof. intros i; rewrite /shiftnP /substP /= /strengthenP /=. @@ -1225,27 +1225,27 @@ Qed. Lemma on_free_vars_ctx_subst_context P s k ctx : on_free_vars_ctx (shiftnP (k + #|s|) P) ctx -> - forallb (on_free_vars P) s -> + forallb (on_free_vars P) s -> on_free_vars_ctx (shiftnP k P) (subst_context s k ctx). Proof. intros onctx ons. rewrite (on_free_vars_ctx_all_term _ _ Universe.type0). rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)). eapply on_free_vars_impl; revgoals. - - eapply on_free_vars_subst_gen => //; tea. + - eapply on_free_vars_subst_gen => //; tea. rewrite -on_free_vars_ctx_all_term //. exact onctx. - intros i. rewrite substP_shiftnP_gen //. Qed. Lemma on_free_vars_ctx_subst_context0 P s ctx : on_free_vars_ctx (shiftnP #|s| P) ctx -> - forallb (on_free_vars P) s -> + forallb (on_free_vars P) s -> on_free_vars_ctx P (subst_context s 0 ctx). Proof. intros onctx ons. rewrite -(shiftnP0 P). eapply on_free_vars_ctx_subst_context => /= //. Qed. - + Lemma on_free_vars_ctx_lift_context p k n ctx : on_free_vars_ctx p ctx = on_free_vars_ctx (strengthenP k n p) (lift_context n k ctx). @@ -1267,7 +1267,7 @@ Proof. Qed. -Lemma on_free_vars_ctx_snoc {P Γ d} : +Lemma on_free_vars_ctx_snoc {P Γ d} : on_free_vars_ctx P (Γ ,, d) = on_free_vars_ctx P Γ && on_free_vars_decl (shiftnP #|Γ| P) d. Proof. @@ -1276,14 +1276,14 @@ Proof. now rewrite on_ctx_free_vars_tip {1 2}/shiftnP /= addnP_shiftnP. Qed. -Lemma on_free_vars_ctx_snoc_impl {P Γ d} : +Lemma on_free_vars_ctx_snoc_impl {P Γ d} : on_free_vars_ctx P (Γ ,, d) -> on_free_vars_ctx P Γ /\ on_free_vars_decl (shiftnP #|Γ| P) d. Proof. now rewrite on_free_vars_ctx_snoc => /andP. Qed. -Lemma on_free_vars_ctx_smash P Γ acc : +Lemma on_free_vars_ctx_smash P Γ acc : on_free_vars_ctx P Γ -> on_free_vars_ctx (shiftnP #|Γ| P) acc -> on_free_vars_ctx P (smash_context acc Γ). @@ -1305,10 +1305,10 @@ Proof. rewrite on_free_vars_ctx_on_ctx_free_vars onacc /=. now rewrite /on_ctx_free_vars /= ont. Qed. - + Lemma on_free_vars_ctx_subst_context_xpredT s ctx : on_free_vars_ctx xpredT ctx -> - forallb (on_free_vars xpredT) s -> + forallb (on_free_vars xpredT) s -> on_free_vars_ctx xpredT (subst_context s 0 ctx). Proof. intros onctx ons. @@ -1316,7 +1316,7 @@ Proof. rewrite shiftnP_xpredT //. Qed. -Lemma on_free_vars_ctx_All_fold P Γ : +Lemma on_free_vars_ctx_All_fold P Γ : on_free_vars_ctx P Γ <~> All_fold (fun Γ => on_free_vars_decl (shiftnP #|Γ| P)) Γ. Proof. split. @@ -1330,28 +1330,28 @@ Lemma term_on_free_vars_ind : forall (P : (nat -> bool) -> term -> Type), (forall (p : nat -> bool) (i : nat), p i -> P p (tRel i)) -> (forall p (i : ident), P p (tVar i)) -> - (forall p (id : nat) (l : list term), + (forall p (id : nat) (l : list term), All (on_free_vars p) l -> - All (P p) l -> + All (P p) l -> P p (tEvar id l)) -> (forall p s, P p (tSort s)) -> - (forall p (na : aname) (t : term) dom codom, + (forall p (na : aname) (t : term) dom codom, on_free_vars p dom -> P p dom -> on_free_vars (shiftnP 1 p) codom -> - P (shiftnP 1 p) codom -> + P (shiftnP 1 p) codom -> P p (tProd na dom codom)) -> - (forall p (na : aname) (ty : term) (body : term), + (forall p (na : aname) (ty : term) (body : term), on_free_vars p ty -> P p ty -> - on_free_vars (shiftnP 1 p) body -> P (shiftnP 1 p) body -> + on_free_vars (shiftnP 1 p) body -> P (shiftnP 1 p) body -> P p (tLambda na ty body)) -> (forall p (na : aname) (def : term) (ty : term) body, - on_free_vars p def -> P p def -> - on_free_vars p ty -> P p ty -> - on_free_vars (shiftnP 1 p) body -> P (shiftnP 1 p) body -> + on_free_vars p def -> P p def -> + on_free_vars p ty -> P p ty -> + on_free_vars (shiftnP 1 p) body -> P (shiftnP 1 p) body -> P p (tLetIn na def ty body)) -> - (forall p (t u : term), - on_free_vars p t -> P p t -> + (forall p (t u : term), + on_free_vars p t -> P p t -> on_free_vars p u -> P p u -> P p (tApp t u)) -> (forall p s (u : list Level.t), P p (tConst s u)) -> (forall p (i : inductive) (u : list Level.t), P p (tInd i u)) -> @@ -1364,19 +1364,19 @@ Lemma term_on_free_vars_ind : on_free_vars (shiftnP #|pred.(pcontext)| p) pred.(preturn) -> P (shiftnP #|pred.(pcontext)| p) pred.(preturn) -> on_free_vars p discr -> - P p discr -> - All (fun br => + P p discr -> + All (fun br => [× on_free_vars_ctx (closedP #|pred.(pparams)| xpredT) br.(bcontext), All_fold (fun Γ => ondecl (P (closedP (#|Γ| + #|pred.(pparams)|) xpredT))) br.(bcontext), on_free_vars (shiftnP #|br.(bcontext)| p) br.(bbody) & P (shiftnP #|br.(bcontext)| p) br.(bbody)]) brs -> P p (tCase ci pred discr brs)) -> - (forall p (s : projection) (t : term), + (forall p (s : projection) (t : term), on_free_vars p t -> P p t -> P p (tProj s t)) -> - (forall p (m : mfixpoint term) (i : nat), + (forall p (m : mfixpoint term) (i : nat), tFixProp (on_free_vars p) (on_free_vars (shiftnP #|fix_context m| p)) m -> tFixProp (P p) (P (shiftnP #|fix_context m| p)) m -> P p (tFix m i)) -> - (forall p (m : mfixpoint term) (i : nat), + (forall p (m : mfixpoint term) (i : nat), tFixProp (on_free_vars p) (on_free_vars (shiftnP #|fix_context m| p)) m -> tFixProp (P p) (P (shiftnP #|fix_context m| p)) m -> P p (tCoFix m i)) -> (forall p pr, P p (tPrim pr)) -> @@ -1388,8 +1388,8 @@ Proof. intros p t. destruct t; intros clt; match goal with H : _ |- _ => apply H - end; auto; simpl in clt; - try move/andP: clt => [cl1 cl2]; + end; auto; simpl in clt; + try move/andP: clt => [cl1 cl2]; try move/andP: cl2 => [cl2 cl3]; try move/andP: cl3 => [cl3 cl4]; try move/andP: cl4 => [cl4 cl5]; @@ -1402,7 +1402,7 @@ Proof. destruct l; constructor; [|apply auxl']. * apply auxt. simpl in clt. now move/andP: clt => [clt cll]. * now move/andP: clt => [clt cll]. - + - solve_all. - revert cl1. generalize (pparams p0). fix auxl' 1. @@ -1411,7 +1411,7 @@ Proof. revert cl3. clear -auxt. generalize (pcontext p0). fix auxl 1. - intros []. + intros []. * cbn. intros _. constructor. * cbn. move/andP => [] cll clc. constructor. @@ -1431,7 +1431,7 @@ Proof. + move: clctx. clear -auxt. generalize (bcontext b). fix auxl 1. - { intros []. + { intros []. * cbn. intros _. constructor. * cbn. move/andP => [] cll clc. constructor. @@ -1442,7 +1442,7 @@ Proof. apply clc. } + now apply auxt. * now apply auxl'. - + - red. len; solve_all; now move/andP: H=> []. @@ -1451,7 +1451,7 @@ Proof. revert clt. generalize (#|mfix|). revert mfix. - fix auxm 1. + fix auxm 1. destruct mfix; [constructor|]. move=> n /= /andP[] /andP[] clb clty clmfix; constructor. * split => //; apply auxt => //. @@ -1465,7 +1465,7 @@ Proof. revert clt. generalize (#|mfix|). revert mfix. - fix auxm 1. + fix auxm 1. destruct mfix; [constructor|]. move=> n /= /andP[] /andP[] clb clty clmfix; constructor. * split => //; apply auxt => //. @@ -1486,7 +1486,7 @@ Proof. destruct r; cbn in *; subst; auto. Qed. -Lemma on_free_vars_ctx_any_xpredT P Γ : +Lemma on_free_vars_ctx_any_xpredT P Γ : on_free_vars_ctx P Γ -> on_free_vars_ctx xpredT Γ. Proof. intros. eapply on_free_vars_ctx_impl; tea => //. @@ -1506,7 +1506,7 @@ Proof. now rewrite on_free_vars_ctx_on_ctx_free_vars_closedP. Qed. -Lemma on_free_vars_ctx_app P Γ Δ : +Lemma on_free_vars_ctx_app P Γ Δ : on_free_vars_ctx P (Γ ,,, Δ) = on_free_vars_ctx P Γ && on_free_vars_ctx (shiftnP #|Γ| P) Δ. Proof. @@ -1520,7 +1520,7 @@ Qed. #[global] Hint Extern 4 (is_true (on_free_vars_ctx _ (_ ,,, _))) => rewrite on_free_vars_ctx_app : fvs. -Lemma on_ctx_free_vars_snoc_ass P Γ na ty : +Lemma on_ctx_free_vars_snoc_ass P Γ na ty : on_ctx_free_vars P Γ -> on_free_vars P ty -> on_ctx_free_vars (PCUICOnFreeVars.shiftnP 1 P) (Γ ,, vass na ty). @@ -1528,7 +1528,7 @@ Proof. now rewrite on_ctx_free_vars_snoc => -> /=; rewrite /on_free_vars_decl /test_decl /=. Qed. -Lemma on_ctx_free_vars_snoc_def P Γ na def ty : +Lemma on_ctx_free_vars_snoc_def P Γ na def ty : on_ctx_free_vars P Γ -> on_free_vars P ty -> on_free_vars P def -> @@ -1538,8 +1538,8 @@ Proof. Qed. #[global] Hint Resolve on_ctx_free_vars_snoc_def on_ctx_free_vars_snoc_ass : pcuic. -Lemma on_ctx_free_vars_snocS P Γ d : - on_ctx_free_vars (PCUICOnFreeVars.shiftnP (S #|Γ|) P) (d :: Γ) = +Lemma on_ctx_free_vars_snocS P Γ d : + on_ctx_free_vars (PCUICOnFreeVars.shiftnP (S #|Γ|) P) (d :: Γ) = on_ctx_free_vars (PCUICOnFreeVars.shiftnP #|Γ| P) Γ && on_free_vars_decl (PCUICOnFreeVars.shiftnP #|Γ| P) d. Proof. rewrite -(shiftnP_add 1). @@ -1569,7 +1569,7 @@ Proof. intros. rewrite on_free_vars_ctx_app H1 /=. eapply on_free_vars_ctx_inst_case_context; trea. -Qed. +Qed. #[global] Hint Resolve on_free_vars_ctx_inst_case_context : fvs. Lemma on_ctx_free_vars_fix_context P Γ mfix : @@ -1602,7 +1602,7 @@ Qed. #[global] Hint Resolve on_ctx_free_vars_snoc_ass on_ctx_free_vars_snoc_def : fvs. #[global] Hint Resolve on_ctx_free_vars_inst_case_context : fvs. #[global] Hint Extern 3 (is_true (_ && _)) => apply/andP; idtac : fvs. -#[global] Hint Extern 4 (is_true (on_ctx_free_vars (shiftnP _ xpred0) _)) => +#[global] Hint Extern 4 (is_true (on_ctx_free_vars (shiftnP _ xpred0) _)) => rewrite on_free_vars_ctx_on_ctx_free_vars : fvs. Lemma on_free_vars_ctx_snoc_ass P Γ na t : @@ -1625,8 +1625,8 @@ Proof. Qed. #[global] Hint Resolve on_free_vars_ctx_snoc_ass on_free_vars_ctx_snoc_def : fvs. - -Lemma on_free_vars_all_subst P s : + +Lemma on_free_vars_all_subst P s : All (on_free_vars P) s -> forall x, on_free_vars xpredT ((s ⋅n ids) x). Proof. diff --git a/pcuic/theories/Syntax/PCUICPosition.v b/pcuic/theories/Syntax/PCUICPosition.v index 4e62c7a09..d4f983dee 100644 --- a/pcuic/theories/Syntax/PCUICPosition.v +++ b/pcuic/theories/Syntax/PCUICPosition.v @@ -74,7 +74,7 @@ Fixpoint validpos t (p : position) {struct p} := match c, t with | app_l, tApp u v => validpos u p | app_r, tApp u v => validpos v p - | case_par par, tCase ci pr c brs => + | case_par par, tCase ci pr c brs => match nth_error pr.(pparams) par with | Some par => validpos par p | None => false @@ -965,7 +965,7 @@ Instance reflect_stack : ReflectEq stack := Definition fill_mfix_hole '((mfix1, m, mfix2) : mfix_hole) (t : term) : mfixpoint term := let def := match m with - | def_hole_type dname dbody rarg => + | def_hole_type dname dbody rarg => {| dname := dname; dtype := t; dbody := dbody; @@ -1196,7 +1196,7 @@ Definition context_hole_context '((ctx1, decl, ctx2) : context_hole) : context : Definition predicate_hole_context (p : predicate_hole) : context := match p with | pred_hole_params _ _ _ _ _ => [] - | pred_hole_return pparams puinst pcontext => + | pred_hole_return pparams puinst pcontext => inst_case_context pparams puinst pcontext end. @@ -1216,7 +1216,7 @@ Definition stack_entry_context (se : stack_entry) : context := | LetIn_in na b B => [vdef na b B] | _ => [] end. - + Definition stack_context : stack -> context := flat_map stack_entry_context. @@ -1234,7 +1234,7 @@ Definition closedn_mfix_hole k '((mfix1, m, mfix2) : mfix_hole) : bool := let k' := (k + #|mfix1| + 1 + #|mfix2|) in let def := match m with - | def_hole_type dname dbody rarg => + | def_hole_type dname dbody rarg => closedn k' dbody | def_hole_body dname dtype rarg => closedn k dtype @@ -1290,12 +1290,12 @@ Definition closedn_stack_entry k se := | Fix mfix idx => closedn_mfix_hole k mfix | CoFix_app mfix idx args => closedn k (mkApps (tCoFix mfix idx) args) | CoFix mfix idx => closedn_mfix_hole k mfix - | Case_pred ci p c brs => + | Case_pred ci p c brs => [&& closedn_predicate_hole k p, closedn k c & test_branches_k_pars (predicate_hole_pars p) closedn k brs] | Case_discr ci p brs => test_predicate_k xpredT closedn k p && test_branches_k p closedn k brs - | Case_branch ci p c brs => + | Case_branch ci p c brs => [&& test_predicate_k xpredT closedn k p, closedn k c & closedn_branches_hole k p brs] | Proj p => true @@ -1311,7 +1311,7 @@ Definition closedn_stack_entry k se := Fixpoint closedn_stack k π := match π with | [] => true - | se :: π => + | se :: π => closedn_stack_entry (k + #|stack_context π|) se && closedn_stack k π end. @@ -1444,7 +1444,7 @@ Qed. Section Stacks. Context (Σ : global_env_ext). Context `{checker_flags}. - + Lemma fill_context_hole_inj c t t' : fill_context_hole c t = fill_context_hole c t' -> t = t'. @@ -1674,12 +1674,12 @@ Require Import ssreflect. (* Lemma fill_mfix_hole_length mfix t : #|fill_mfix_hole mfix t| = #| *) -(* Lemma closedn_fill_hole k mfix t : closedn k (fill_mfix_hole mfix t) = closedn (#|stack_entry_context se| + k) t && +(* Lemma closedn_fill_hole k mfix t : closedn k (fill_mfix_hole mfix t) = closedn (#|stack_entry_context se| + k) t && closedn_stack_entry k se. Proof. destruct se; simpl => //; try bool_congr. *) -Lemma closedn_fill_hole k t se : closedn k (fill_hole t se) = closedn (#|stack_entry_context se| + k) t && +Lemma closedn_fill_hole k t se : closedn k (fill_hole t se) = closedn (#|stack_entry_context se| + k) t && closedn_stack_entry k se. Proof. destruct se; simpl => //; try bool_congr; try ring. @@ -1699,11 +1699,11 @@ Proof. rewrite !andb_assoc andb_true_r /= map_length. ring. - destruct p; cbn. * unfold test_predicate_k; cbn. - rewrite !forallb_app /=. len. ring_simplify. + rewrite !forallb_app /=. len. ring_simplify. replace (k + #|pcontext|) with (#|pcontext| + k) by lia. rewrite - !andb_assoc. repeat bool_congr. apply forallb_ext. intros []; cbn. - unfold test_branch_k, test_branch_k_pars; cbn; len. + unfold test_branch_k, test_branch_k_pars; cbn; len. now rewrite -Nat.add_assoc /=. * unfold test_predicate_k; cbn; len. rewrite - !andb_assoc. repeat bool_congr. @@ -1717,6 +1717,6 @@ Proof. induction π in k, t |- * => //. simpl. rewrite IHπ. bool_congr. len. - rewrite closedn_fill_hole. + rewrite closedn_fill_hole. rewrite Nat.add_assoc (Nat.add_comm #|stack_context π| k). ring. Qed. diff --git a/pcuic/theories/Syntax/PCUICReflect.v b/pcuic/theories/Syntax/PCUICReflect.v index 73c6d6441..bb56cc166 100644 --- a/pcuic/theories/Syntax/PCUICReflect.v +++ b/pcuic/theories/Syntax/PCUICReflect.v @@ -123,14 +123,14 @@ Proof. intros eqpq; split; intros []; constructor; intuition. Qed. -Lemma reflectEq_andb {A B} {ra : ReflectEq A} {rb : ReflectEq B} {x x' : A} {y y' : B} : +Lemma reflectEq_andb {A B} {ra : ReflectEq A} {rb : ReflectEq B} {x x' : A} {y y' : B} : reflectProp ({| pr1 := x; pr2 := y |} = {| pr1 := x'; pr2 := y' |}) ((x == x') && (y == y')). Proof. destruct (eqb_spec x x'); try constructor; try congruence. destruct (eqb_spec y y'); constructor; congruence. Qed. -Lemma reflectEq_andb_3 {A B C} {ra : ReflectEq A} {rb : ReflectEq B} {rc : ReflectEq C} {x x' : A} {y y' : B} {z z' : C} : +Lemma reflectEq_andb_3 {A B C} {ra : ReflectEq A} {rb : ReflectEq B} {rc : ReflectEq C} {x x' : A} {y y' : B} {z z' : C} : reflectProp ({| pr1 := x; pr2 := {| pr1 := y; pr2 := z |} |} = {| pr1 := x'; pr2 := {| pr1 := y'; pr2 := z' |} |}) ((x == x') && (y == y') && (z == z')). Proof. destruct (eqb_spec x x'); try constructor; try congruence. @@ -162,14 +162,14 @@ Proof. split. eapply noConfusion_inv. eapply noConfusion. Qed. -Lemma reflectProp_sigma_simpl {A B : Type} (x x' : A) (y y' : B) b : +Lemma reflectProp_sigma_simpl {A B : Type} (x x' : A) (y y' : B) b : reflectProp (x = x' /\ y = y') b <-> reflectProp ({| pr1 := x; pr2 := y|} = {| pr1 := x'; pr2 := y' |}) b. Proof. eapply reflectProp_equiv. intuition auto; congruence. Qed. - -Lemma reflect_prop_list {A} {l l' : list A} {p : A -> A -> bool} : + +Lemma reflect_prop_list {A} {l l' : list A} {p : A -> A -> bool} : All (fun x : A => forall y : A, reflectProp (x = y) (p x y)) l -> reflectProp (l = l') (forallb2 p l l'). Proof. @@ -183,7 +183,7 @@ Qed. Local Ltac t := try constructor; intuition auto; try congruence. Local Ltac t' := rewrite /= ?andb_false_r ?andb_true_r /=; t. -Lemma reflect_prop_context_decl d d' : +Lemma reflect_prop_context_decl d d' : ondecl (fun x : term => forall y : term, reflectProp (x = y) (eqb_term x y)) d -> reflectProp (d = d') (eqb_context_decl eqb_term d d'). Proof. @@ -219,7 +219,7 @@ Proof. case: (reflect_prop_list (l:=l) (l' := brs)); t'. { eapply All_impl; tea; cbv beta. intros [bctx bbody] []. intros [bctx' bbody']; cbn in *. - case: (reflect_prop_list (l' := bctx')); t'. + case: (reflect_prop_list (l' := bctx')); t'. eapply All_impl; tea; cbv beta; intros. now eapply reflect_prop_context_decl. destruct (r0 bbody'); t'. } @@ -247,7 +247,7 @@ Qed. #[global] Instance EqDec_term : EqDec term := ReflectEq_EqDec _. -(** This is defined using reflect_list, so no issue of computing with proofs here. *) +(** This is defined using reflect_list, so no issue of computing with proofs here. *) #[global] Instance eqb_ctx : ReflectEq context := _. @@ -269,7 +269,7 @@ Next Obligation. Proof. destruct x, y; cbn; case: eqb_spec; t. Qed. Definition eqb_context_decl (x y : context_decl) := - eqb (x.(decl_name), x.(decl_body), x.(decl_type)) + eqb (x.(decl_name), x.(decl_body), x.(decl_type)) (y.(decl_name), y.(decl_body), y.(decl_type)). #[program, global] @@ -311,9 +311,9 @@ Proof. destruct x, y; cbn in *. unfold eqb_constructor_body; cbn -[eqb]. finish_reflect. Qed. - + Definition eqb_projection_body (x y : projection_body) := - (x.(proj_name), x.(proj_type), x.(proj_relevance)) == + (x.(proj_name), x.(proj_type), x.(proj_relevance)) == (y.(proj_name), y.(proj_type), y.(proj_relevance)). #[program, global] diff --git a/pcuic/theories/Syntax/PCUICRenameDef.v b/pcuic/theories/Syntax/PCUICRenameDef.v index 0143fa183..e6fc8d62a 100644 --- a/pcuic/theories/Syntax/PCUICRenameDef.v +++ b/pcuic/theories/Syntax/PCUICRenameDef.v @@ -24,17 +24,17 @@ Context `{cf : checker_flags}. (* Notion of valid renaming without typing information. *) -(** We might want to relax this to allow "renamings" that change e.g. - the universes or names, but should generalize the renaming operation at +(** We might want to relax this to allow "renamings" that change e.g. + the universes or names, but should generalize the renaming operation at the same time *) (** Remark: renaming allows instantiating an assumption with a well-typed body *) Definition urenaming (P : nat -> bool) Γ Δ f := - forall i decl, P i -> + forall i decl, P i -> nth_error Δ i = Some decl -> ∑ decl', (nth_error Γ (f i) = Some decl') × (eq_binder_annot decl.(decl_name) decl'.(decl_name) × - ((rename (f ∘ rshiftk (S i)) decl.(decl_type) = + ((rename (f ∘ rshiftk (S i)) decl.(decl_type) = rename (rshiftk (S (f i))) decl'.(decl_type)) × on_Some_or_None (fun body => Some (rename (f ∘ rshiftk (S i)) body) = option_map (rename (rshiftk (S (f i)))) decl'.(decl_body)) decl.(decl_body))). diff --git a/pcuic/theories/Syntax/PCUICTactics.v b/pcuic/theories/Syntax/PCUICTactics.v index 364d45bdb..381bec642 100644 --- a/pcuic/theories/Syntax/PCUICTactics.v +++ b/pcuic/theories/Syntax/PCUICTactics.v @@ -18,16 +18,16 @@ Ltac pcuic_core := Ltac pcuic := pcuic_core || ltac:(try (red; repeat red; cbn in *; pcuic_core)). -Definition lengths := - (@context_assumptions_expand_lets_ctx, +Definition lengths := + (@context_assumptions_expand_lets_ctx, @context_assumptions_subst_context, - context_assumptions_fold, + context_assumptions_fold, @context_assumptions_app, @context_assumptions_map, @context_assumptions_mapi, @context_assumptions_mapi_context, @context_assumptions_smash_context, - @context_assumptions_subst_instance, + @context_assumptions_subst_instance, @context_assumptions_lift_context, @inst_case_context_assumptions, @expand_lets_ctx_length, @subst_context_length, @@ -37,7 +37,7 @@ Definition lengths := @map_length, @mapi_length, @mapi_rec_length, @map_InP_length, @fold_context_length, @fold_context_k_length, @cofix_subst_length, @fix_subst_length, - fix_context_length, + fix_context_length, @smash_context_length, @arities_context_length, @forget_types_length, @@ -48,12 +48,12 @@ Definition lengths := @inst_case_context_length, @ind_predicate_context_length, @map_context_length, @skipn_map_length, - @mapi_context_length, idsn_length, + @mapi_context_length, idsn_length, @projs_length, ren_ids_length). -Ltac len ::= +Ltac len ::= repeat (rewrite !lengths /= //); try solve [lia_f_equal]. - + Tactic Notation "len" "in" hyp(id) := repeat (rewrite !lengths /= // in id); try solve [lia_f_equal]. diff --git a/pcuic/theories/Syntax/PCUICUnivSubst.v b/pcuic/theories/Syntax/PCUICUnivSubst.v index 6bfcabeeb..0ed1b1a8a 100644 --- a/pcuic/theories/Syntax/PCUICUnivSubst.v +++ b/pcuic/theories/Syntax/PCUICUnivSubst.v @@ -16,11 +16,11 @@ Qed. #[global] Hint Rewrite subst_instance_instance_length : len. -Lemma subst_instance_nil {A} {ua : UnivSubst A} u (xs : list A) : +Lemma subst_instance_nil {A} {ua : UnivSubst A} u (xs : list A) : subst_instance u [] = []. Proof. reflexivity. Qed. -Lemma subst_instance_cons {A} {ua : UnivSubst A} u x (xs : list A) : +Lemma subst_instance_cons {A} {ua : UnivSubst A} u x (xs : list A) : subst_instance u (x :: xs) = subst_instance u x :: subst_instance u xs. Proof. reflexivity. Qed. diff --git a/pcuic/theories/Syntax/PCUICViews.v b/pcuic/theories/Syntax/PCUICViews.v index 45be6a948..44fee184d 100644 --- a/pcuic/theories/Syntax/PCUICViews.v +++ b/pcuic/theories/Syntax/PCUICViews.v @@ -11,7 +11,7 @@ Set Equations Transparent. Fixpoint isFixLambda_app (t : term) : bool := match t with | tApp (tFix _ _) _ => true - | tApp (tLambda _ _ _) _ => true + | tApp (tLambda _ _ _) _ => true | tApp f _ => isFixLambda_app f | _ => false end. @@ -37,14 +37,14 @@ Proof. apply (fix_lambda_app_fix mfix idx [] u). Defined. -Lemma eq_pair_transport {A B} (x y : A) (t : B y) (eq : y = x) : - (x; eq_rect _ (fun x => B x) t _ eq) = (y; t) :> ∑ x, B x. +Lemma eq_pair_transport {A B} (x y : A) (t : B y) (eq : y = x) : + (x; eq_rect _ (fun x => B x) t _ eq) = (y; t) :> ∑ x, B x. Proof. - now destruct eq. + now destruct eq. Qed. -Lemma view_lambda_fix_app_fix_app_sigma mfix idx l a : - ((mkApps (tFix mfix idx) l); view_lambda_fix_app (mkApps (tFix mfix idx) l) a) = +Lemma view_lambda_fix_app_fix_app_sigma mfix idx l a : + ((mkApps (tFix mfix idx) l); view_lambda_fix_app (mkApps (tFix mfix idx) l) a) = ((mkApps (tFix mfix idx) l); fix_lambda_app_fix mfix idx l a) :> ∑ t, fix_lambda_app_view t a. Proof. induction l using rev_ind; simpl; auto. @@ -54,8 +54,8 @@ Proof. now rewrite eq_pair_transport. Qed. -Lemma view_lambda_fix_app_lambda_app_sigma na ty b l a : - ((mkApps (tLambda na ty b) l); view_lambda_fix_app (mkApps (tLambda na ty b) l) a) = +Lemma view_lambda_fix_app_lambda_app_sigma na ty b l a : + ((mkApps (tLambda na ty b) l); view_lambda_fix_app (mkApps (tLambda na ty b) l) a) = ((mkApps (tLambda na ty b) l); fix_lambda_app_lambda na ty b l a) :> ∑ t, fix_lambda_app_view t a. Proof. induction l using rev_ind; simpl; auto. @@ -67,16 +67,16 @@ Qed. Set Equations With UIP. -Lemma view_lambda_fix_app_fix_app mfix idx l a : - view_lambda_fix_app (mkApps (tFix mfix idx) l) a = +Lemma view_lambda_fix_app_fix_app mfix idx l a : + view_lambda_fix_app (mkApps (tFix mfix idx) l) a = fix_lambda_app_fix mfix idx l a. Proof. pose proof (view_lambda_fix_app_fix_app_sigma mfix idx l a). now noconf H. Qed. -Lemma view_lambda_fix_app_lambda_app na ty b l a : - view_lambda_fix_app (mkApps (tLambda na ty b) l) a = +Lemma view_lambda_fix_app_lambda_app na ty b l a : + view_lambda_fix_app (mkApps (tLambda na ty b) l) a = fix_lambda_app_lambda na ty b l a. Proof. pose proof (view_lambda_fix_app_lambda_app_sigma na ty b l a). @@ -136,9 +136,9 @@ Equations view_construct0_cofix (t : term) : construct0_cofix_view t := | t => construct0_cofix_other t _ }. Lemma isFixLambda_app_mkApps t l : isFixLambda_app t -> isFixLambda_app (mkApps t l). -Proof. +Proof. induction l using rev_ind; simpl; auto. - rewrite mkApps_app. + rewrite mkApps_app. intros isf. specialize (IHl isf). simpl. rewrite IHl. destruct (mkApps t l); auto. Qed. @@ -161,12 +161,12 @@ Proof. Qed. Lemma isFixLambda_app_mkApps' t l x : isFixLambda t -> isFixLambda_app (tApp (mkApps t l) x). -Proof. +Proof. induction l using rev_ind; simpl; auto. destruct t; auto. simpl => //. intros isl. specialize (IHl isl). simpl in IHl. - now rewrite mkApps_app /=. + now rewrite mkApps_app /=. Qed. Lemma bool_pirr (b b' : bool) (p q : b = b') : p = q. diff --git a/pcuic/theories/TemplateToPCUIC.v b/pcuic/theories/TemplateToPCUIC.v index d503a79a9..03b590283 100644 --- a/pcuic/theories/TemplateToPCUIC.v +++ b/pcuic/theories/TemplateToPCUIC.v @@ -19,7 +19,7 @@ Definition float64_to_model (f : PrimFloat.float) : float64_model := Section Map2Bias. Context {A B C} (f : A -> B -> C) (default : B). - + Fixpoint map2_bias_left (l : list A) (l' : list B) : list C := match l, l' with | [], [] => [] @@ -44,19 +44,19 @@ End Map2Bias. Section Trans. Context (Σ : global_env_map). - Definition dummy_decl : context_decl := + Definition dummy_decl : context_decl := vass {| binder_name := nAnon; binder_relevance := Relevant |} (tSort Universe.type0). - Definition trans_predicate ind mdecl idecl pparams puinst pcontext preturn := + Definition trans_predicate ind mdecl idecl pparams puinst pcontext preturn := let pctx := map2_bias_left set_binder_name dummy_decl pcontext (ind_predicate_context ind mdecl idecl) in - {| pparams := pparams; + {| pparams := pparams; puinst := puinst; pcontext := pctx; preturn := preturn |}. Definition trans_branch ind mdecl cdecl bcontext bbody := let bctx := map2_bias_left set_binder_name dummy_decl bcontext (cstr_branch_context ind mdecl cdecl) in - {| bcontext := bctx; + {| bcontext := bctx; bbody := bbody |}. Fixpoint trans (t : Ast.term) : term := @@ -77,13 +77,13 @@ Section Trans. let p' := Ast.map_predicate id trans trans p in let brs' := List.map (Ast.map_branch trans) brs in match TransLookup.lookup_inductive Σ ci.(ci_ind) with - | Some (mdecl, idecl) => + | Some (mdecl, idecl) => let tp := trans_predicate ci.(ci_ind) mdecl idecl p'.(Ast.pparams) p'.(Ast.puinst) p'.(Ast.pcontext) p'.(Ast.preturn) in - let tbrs := - map2 (fun cdecl br => trans_branch ci.(ci_ind) mdecl cdecl br.(Ast.bcontext) br.(Ast.bbody)) + let tbrs := + map2 (fun cdecl br => trans_branch ci.(ci_ind) mdecl cdecl br.(Ast.bcontext) br.(Ast.bbody)) idecl.(ind_ctors) brs' in tCase ci tp (trans c) tbrs - | None => + | None => (** We build an ill-formed case if the term + environment are not well-formed. But we still give the right length to the context so that all syntactic operations still work. *) @@ -110,15 +110,15 @@ Section Trans. decl_type := trans d.(decl_type) |}. Definition trans_local Γ := List.map trans_decl Γ. - + Definition trans_constructor_body (d : Ast.Env.constructor_body) := - {| cstr_name := d.(Ast.Env.cstr_name); + {| cstr_name := d.(Ast.Env.cstr_name); cstr_args := trans_local d.(Ast.Env.cstr_args); - cstr_indices := map trans d.(Ast.Env.cstr_indices); + cstr_indices := map trans d.(Ast.Env.cstr_indices); cstr_type := trans d.(Ast.Env.cstr_type); cstr_arity := d.(Ast.Env.cstr_arity) |}. Definition trans_projection_body (d : Ast.Env.projection_body) := - {| proj_name := d.(Ast.Env.proj_name); + {| proj_name := d.(Ast.Env.proj_name); proj_type := trans d.(Ast.Env.proj_type); proj_relevance := d.(Ast.Env.proj_relevance) |}. @@ -133,7 +133,7 @@ Section Trans. ind_projs := List.map trans_projection_body d.(Ast.Env.ind_projs) |}. Definition trans_constant_body bd := - {| cst_type := trans bd.(Ast.Env.cst_type); + {| cst_type := trans bd.(Ast.Env.cst_type); cst_body := option_map trans bd.(Ast.Env.cst_body); cst_universes := bd.(Ast.Env.cst_universes); cst_relevance := bd.(Ast.Env.cst_relevance) |}. @@ -154,7 +154,7 @@ Section Trans. End Trans. Program Definition add_global_decl (env : global_env_map) (d : kername × global_decl) := - {| trans_env_env := add_global_decl env.(trans_env_env) d; + {| trans_env_env := add_global_decl env.(trans_env_env) d; trans_env_map := EnvMap.add d.1 d.2 env.(trans_env_map) |}. Next Obligation. pose proof env.(trans_env_repr). @@ -162,13 +162,13 @@ Next Obligation. Qed. Definition trans_global_decls env (d : Ast.Env.global_declarations) : global_env_map := - fold_right (fun decl Σ' => + fold_right (fun decl Σ' => let decl' := on_snd (trans_global_decl Σ') decl in add_global_decl Σ' decl') env d. -Definition empty_trans_env univs retro := +Definition empty_trans_env univs retro := let init_global_env := {| universes := univs; declarations := []; retroknowledge := retro |} in - {| trans_env_env := init_global_env; + {| trans_env_env := init_global_env; trans_env_map := EnvMap.empty; trans_env_repr := fun y => eq_refl |}. @@ -180,6 +180,6 @@ Definition trans_global (Σ : Ast.Env.global_env_ext) : global_env_ext_map := (trans_global_env (fst Σ), snd Σ). Definition trans_template_program (p : TemplateProgram.template_program) : pcuic_program := - let Σ' := trans_global (Ast.Env.empty_ext p.1) in + let Σ' := trans_global (Ast.Env.empty_ext p.1) in (Σ', trans Σ' p.2). - + diff --git a/pcuic/theories/TemplateToPCUICCorrectness.v b/pcuic/theories/TemplateToPCUICCorrectness.v index 1c498f47c..1ec2f6ec4 100644 --- a/pcuic/theories/TemplateToPCUICCorrectness.v +++ b/pcuic/theories/TemplateToPCUICCorrectness.v @@ -3,7 +3,7 @@ From Coq Require Import ssreflect. From MetaCoq.Template Require Import config utils EnvMap. From MetaCoq.Template Require Ast TypingWf WfAst TermEquality. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCumulativity - PCUICLiftSubst PCUICEquality PCUICReduction + PCUICLiftSubst PCUICEquality PCUICReduction PCUICUnivSubst PCUICTyping PCUICGlobalEnv TemplateToPCUIC PCUICWeakeningConv PCUICWeakeningTyp PCUICWeakeningEnv PCUICSubstitution PCUICGeneration PCUICCasesContexts @@ -18,28 +18,28 @@ Set Default Proof Using "Type*". Coercion Ast.Env.fst_ctx : Ast.Env.global_env_ext >-> Ast.Env.global_env. -Definition lengths := +Definition lengths := (@Ast.Env.context_assumptions_subst_context, Ast.Env.context_assumptions_app, @Ast.Env.context_assumptions_subst_instance, @Ast.Env.context_assumptions_lift_context, @Ast.Env.expand_lets_ctx_length, @Ast.Env.subst_context_length, - @Ast.Env.subst_instance_length, - @Ast.Env.expand_lets_k_ctx_length, + @Ast.Env.subst_instance_length, + @Ast.Env.expand_lets_k_ctx_length, @Ast.inds_length, @Ast.Env.lift_context_length, @app_length, @List.rev_length, @Ast.Env.extended_subst_length, @reln_length, - Nat.add_0_r, @app_nil_r, + Nat.add_0_r, @app_nil_r, @map_length, @mapi_length, @mapi_rec_length, @fold_context_k_length, @Typing.cofix_subst_length, @Typing.fix_subst_length, @Ast.Env.smash_context_length, @Ast.Env.arities_context_length). -Definition plengths := +Definition plengths := (@context_assumptions_subst_context, @context_assumptions_app, @context_assumptions_subst_instance, @context_assumptions_lift_context, @expand_lets_ctx_length, @subst_context_length, @subst_instance_length, @expand_lets_k_ctx_length, @inds_length, @lift_context_length, @app_length, @List.rev_length, @extended_subst_length, @reln_length, - Nat.add_0_r, @app_nil_r, + Nat.add_0_r, @app_nil_r, @map_length, @mapi_length, @mapi_rec_length, @fold_context_k_length, @cofix_subst_length, @fix_subst_length, @smash_context_length, @context_assumptions_smash_context, @@ -51,19 +51,19 @@ Proof. rewrite /Ast.ind_predicate_context /=. now len. Qed. -Definition pclengths := +Definition pclengths := (@PCUICCases.ind_predicate_context_length, @PCUICCases.cstr_branch_context_length, @PCUICCases.inst_case_branch_context_length, @PCUICCases.inst_case_predicate_context_length, @ind_predicate_context_length). -Ltac len ::= +Ltac len ::= repeat (rewrite !lengths /= // || rewrite !plengths /= // || rewrite !pclengths /= //); try lia. - + Tactic Notation "len" "in" hyp(id) := - repeat (rewrite !lengths /= // in id || rewrite !plengths /= // in id || + repeat (rewrite !lengths /= // in id || rewrite !plengths /= // in id || rewrite !pclengths /= // in id); try lia. @@ -78,7 +78,7 @@ Lemma wf_fresh_globals {cf : checker_flags} (Σ : global_env) : wf Σ -> EnvMap. Proof. destruct Σ as [univs Σ]; cbn. move=> [] onu; cbn. induction 1; constructor; auto. - destruct o; auto. + destruct o; auto. Qed. Lemma of_global_env_cons {cf:checker_flags} d g : EnvMap.fresh_globals (add_global_decl g d).(declarations) -> @@ -124,7 +124,7 @@ Lemma mkApps_app f l l' : mkApps f (l ++ l') = mkApps (mkApps f l) l'. Proof. revert f l'; induction l; simpl; trivial. Qed. - + Ltac maps := rewrite_strat (topdown (old_hints map)). Ltac lengths := rewrite_strat (topdown (hints len)). @@ -135,8 +135,8 @@ Proof. revert t a; induction l; intros; simpl; try congruence. Qed. -Lemma trans_global_decls_app {Σ : global_env_map} (Σ' Σ'' : Ast.Env.global_declarations) : - trans_global_decls Σ (Σ' ++ Σ'') = +Lemma trans_global_decls_app {Σ : global_env_map} (Σ' Σ'' : Ast.Env.global_declarations) : + trans_global_decls Σ (Σ' ++ Σ'') = trans_global_decls (trans_global_decls Σ Σ'') Σ'. Proof. rewrite /trans_global_decls. @@ -169,14 +169,14 @@ Definition wf_global_decl {cf} (Σ : Ast.Env.global_env_ext) kn decl := Lemma trans_lookup_env {cf} {Σ : Ast.Env.global_env} cst {wfΣ : Typing.wf Σ} : match Ast.Env.lookup_env Σ cst with | None => lookup_env (trans_global_env Σ) cst = None - | Some d => + | Some d => ∑ Σ' : Ast.Env.global_env, [× Ast.Env.extends_decls Σ' Σ, - Typing.wf Σ', + Typing.wf Σ', wf_global_decl (Σ', Ast.universes_decl_of_decl d) cst d, extends_decls (trans_global_env Σ') (trans_global_env Σ) & lookup_env (trans_global_env Σ) cst = Some (trans_global_decl (trans_global_env Σ') d)] - end. + end. Proof. destruct Σ as [univs Σ retro]. induction Σ. @@ -202,7 +202,7 @@ Proof. destruct (Ast.Env.lookup_global Σ cst) eqn:h. destruct IHΣ as [Σ' [ext wf ext' hl]]. exists Σ'. split => //. - destruct ext as [equ [? eq]]. + destruct ext as [equ [? eq]]. split => //. exists ((kn, d) :: x). cbn. cbn in eq. now rewrite eq. destruct hl as [equ' [? eq']]. @@ -214,7 +214,7 @@ Proof. cbn. now rewrite eqk. Qed. -Lemma cs_subset_trans cs cs' cs'' : +Lemma cs_subset_trans cs cs' cs'' : cs ⊂_cs cs' -> cs' ⊂_cs cs'' -> cs ⊂_cs cs''. Proof. intros [] []; split; [lsets|csets]. @@ -229,7 +229,7 @@ Proof. - now etransitivity; tea. Qed. -Lemma trans_weakening {cf} Σ {Σ' : global_env_map} t : +Lemma trans_weakening {cf} Σ {Σ' : global_env_map} t : Typing.wf Σ -> extends_decls (trans_global_env Σ) Σ' -> wf Σ' -> WfAst.wf Σ t -> trans (trans_global_env Σ) t = trans Σ' t. @@ -251,9 +251,9 @@ Proof. red in X0. f_equal => //. rewrite /id. unfold trans_predicate. f_equal; solve_all. f_equal. solve_all. -Qed. +Qed. -Lemma trans_decl_weakening {cf} Σ {Σ' : global_env_map} t : +Lemma trans_decl_weakening {cf} Σ {Σ' : global_env_map} t : Typing.wf Σ -> extends_decls (trans_global_env Σ) Σ' -> wf Σ' -> WfAst.wf_decl Σ t -> trans_decl (trans_global_env Σ) t = trans_decl Σ' t. @@ -261,7 +261,7 @@ Proof. intros wfΣ ext wfΣ' wft. rewrite /trans_decl; destruct t as [na [b|] ty] => /=; f_equal; rewrite trans_weakening => //; apply wft. -Qed. +Qed. Lemma trans_local_length {Σ : global_env_map} Γ : #|trans_local Σ Γ| = #|Γ|. Proof. now rewrite map_length. Qed. @@ -269,7 +269,7 @@ Proof. now rewrite map_length. Qed. #[global] Hint Rewrite @trans_local_length : len. -Lemma trans_local_weakening {cf} Σ {Σ' : global_env_map} t : +Lemma trans_local_weakening {cf} Σ {Σ' : global_env_map} t : Typing.wf Σ -> extends_decls (trans_global_env Σ) Σ' -> wf Σ' -> All (WfAst.wf_decl Σ) t -> trans_local (trans_global_env Σ) t = trans_local Σ' t. @@ -279,9 +279,9 @@ Proof. f_equal. 2:apply IHa. rewrite /trans_decl; destruct x as [na [b|] ty] => /=; f_equal; rewrite trans_weakening => //; apply p. -Qed. +Qed. -Lemma trans_ind_body_weakening {cf} Σ {Σ' : global_env_map} b : +Lemma trans_ind_body_weakening {cf} Σ {Σ' : global_env_map} b : Typing.wf Σ -> extends_decls (trans_global_env Σ) Σ' -> wf Σ' -> TypingWf.wf_inductive_body Σ b -> trans_one_ind_body (trans_global_env Σ) b = trans_one_ind_body Σ' b. @@ -299,7 +299,7 @@ Proof. rewrite trans_weakening //. Qed. -Lemma trans_global_decl_weaken {cf} (Σ : Ast.Env.global_env_ext) {Σ' : global_env_map} kn d : +Lemma trans_global_decl_weaken {cf} (Σ : Ast.Env.global_env_ext) {Σ' : global_env_map} kn d : Typing.wf Σ -> extends_decls (trans_global_env Σ) Σ' -> wf Σ' -> wf_global_decl Σ kn d -> trans_global_decl (trans_global_env Σ) d = trans_global_decl Σ' d. @@ -334,8 +334,8 @@ Qed. Lemma trans_lookup {cf} Σ cst : Typing.wf Σ -> - wf (trans_global_env Σ) -> - lookup_env (trans_global_env Σ) cst = + wf (trans_global_env Σ) -> + lookup_env (trans_global_env Σ) cst = option_map (trans_global_decl (trans_global_env Σ)) (Ast.Env.lookup_env Σ cst). Proof. intros wf wf'. @@ -352,15 +352,15 @@ Section Translation. Notation trans_decl := (trans_decl (trans_global_env Σ)). Notation trans_local := (trans_local (trans_global_env Σ)). - Ltac dest_lookup := + Ltac dest_lookup := destruct TransLookup.lookup_inductive as [[mdecl idecl]|]. - Lemma map_map2 {A B C D} (f : A -> B) (g : C -> D -> A) l l' : + Lemma map_map2 {A B C D} (f : A -> B) (g : C -> D -> A) l l' : map f (map2 g l l') = map2 (fun x y => f (g x y)) l l'. Proof. induction l in l' |- *; destruct l'; simpl; auto. f_equal. apply IHl. Qed. - + Lemma trans_lift n k t : trans (Template.Ast.lift n k t) = lift n k (trans t). Proof. @@ -401,7 +401,7 @@ Proof. rewrite mkApps_app. reflexivity. Qed. -Lemma trans_mkApps u v : +Lemma trans_mkApps u v : trans (Template.Ast.mkApps u v) = mkApps (trans u) (List.map trans v). Proof. revert u; induction v. @@ -412,7 +412,7 @@ Proof. apply trans_mkApp. Qed. -Lemma trans_subst t k u : +Lemma trans_subst t k u : trans (Template.Ast.subst t k u) = subst (map trans t) k (trans u). Proof. revert k. induction u using Template.Induction.term_forall_list_ind; simpl; intros; try congruence. @@ -451,10 +451,10 @@ Qed. Notation Tterm := Template.Ast.term. Notation Tcontext := Template.Ast.Env.context. -Lemma All_map2 {A B C} P (l : list A) (l' : list B) (f g : A -> B -> C) : +Lemma All_map2 {A B C} P (l : list A) (l' : list B) (f g : A -> B -> C) : All P l' -> (forall x y, P y -> f x y = g x y) -> - map2 f l l' = map2 g l l'. + map2 f l l' = map2 g l l'. Proof. induction 1 in l |- * => Hfg /=; destruct l => //. cbn. rewrite IHX //. f_equal. @@ -468,7 +468,7 @@ Proof. { f_equal. rewrite !map_map_compose. solve_all. } { rewrite IHt. rewrite map_map_compose. rewrite mkApps_morphism; auto. f_equal. - rewrite !map_map_compose. solve_all. } + rewrite !map_map_compose. solve_all. } 2-3:f_equal; auto; unfold BasicAst.tFixProp, Ast.tCaseBrsProp in *; repeat toAll; solve_list. destruct X; red in X0. @@ -503,7 +503,7 @@ Proof. destruct H as []. red in H. epose proof (trans_lookup Σ (inductive_mind ci.(ci_ind)) wfΣ wf'). destruct TransLookup.lookup_inductive as [[mdecl' idecl']|] eqn:hl => //. -Qed. +Qed. (* TODO Duplicate? *) Lemma Alli_map_option_out_mapi_Some_spec {A B B'} (f : nat -> A -> option B) (g' : B -> B') @@ -553,7 +553,7 @@ Qed. Definition on_pair {A B C D} (f : A -> B) (g : C -> D) (x : A * C) := (f (fst x), g (snd x)). -Lemma trans_inds kn u bodies : map trans (Ast.inds kn u bodies) = +Lemma trans_inds kn u bodies : map trans (Ast.inds kn u bodies) = inds kn u (map (trans_one_ind_body (trans_global_env Σ)) bodies). Proof. unfold inds, Ast.inds. rewrite map_length. @@ -580,7 +580,7 @@ Proof. now rewrite IHctx. Qed. -Lemma trans_local_subst_instance u (Γ : Ast.Env.context) : +Lemma trans_local_subst_instance u (Γ : Ast.Env.context) : trans_local (subst_instance u Γ) = subst_instance u (trans_local Γ). Proof. rewrite /subst_instance /=. @@ -610,7 +610,7 @@ Notation trΣ := (trans_global_env Σ). Lemma trans_ind_params mdecl : trans_local (Ast.Env.ind_params mdecl) = ind_params (trans_minductive_body trΣ mdecl). Proof. reflexivity. Qed. -Lemma trans_ind_bodies mdecl : map (trans_one_ind_body trΣ) (Ast.Env.ind_bodies mdecl) = +Lemma trans_ind_bodies mdecl : map (trans_one_ind_body trΣ) (Ast.Env.ind_bodies mdecl) = ind_bodies (trans_minductive_body (trans_global_env Σ) mdecl). Proof. reflexivity. Qed. @@ -638,7 +638,7 @@ Proof. simpl. now rewrite map_length. Qed. Lemma trans_ind_npars mdecl : Ast.Env.ind_npars mdecl = ind_npars (trans_minductive_body trΣ mdecl). Proof. simpl. reflexivity. Qed. -Lemma trans_reln l p Γ : map trans (Ast.Env.reln l p Γ) = +Lemma trans_reln l p Γ : map trans (Ast.Env.reln l p Γ) = reln (map trans l) p (trans_local Γ). Proof. induction Γ as [|[na [b|] ty] Γ] in l, p |- *; simpl; auto. @@ -826,7 +826,7 @@ Section Trans_Global. induction 1; cbn; constructor; auto. Qed. - Lemma All2_All2_All2_All3 {A B C} (P : A -> B -> C -> Type) (Q : A -> B -> Type) (Q' : A -> C -> Type) + Lemma All2_All2_All2_All3 {A B C} (P : A -> B -> C -> Type) (Q : A -> B -> Type) (Q' : A -> C -> Type) (R : B -> C -> Type) (x : list A) (l : list B) (l' : list C): All2 Q x l -> All2 Q' x l' -> All2 R l l' -> @@ -848,7 +848,7 @@ Section Trans_Global. induction t using Induction.term_forall_list_rect in sub, Rle, napp, wt, u, wu, e |- *. all: invs e; cbn. all: try solve [ constructor ; auto ]. - all: repeat (match goal with + all: repeat (match goal with | H : WfAst.wf _ (_ _) |- _ => apply WfAst.wf_inv in H; simpl in H | H : _ /\ _ |- _ => destruct H end). @@ -983,7 +983,7 @@ Section Trans_Global. intuition auto using trans_eq_term. Qed. End Trans_Global. - + Section Trans_Global. Context {cf : checker_flags}. Context (Σ : Ast.Env.global_env). @@ -994,7 +994,7 @@ Section Trans_Global. induction l in n |- *; destruct n; trivial. simpl in *. congruence. Qed. - + Lemma trans_extended_subst Γ k : map (trans Σ') (Ast.Env.extended_subst Γ k) = extended_subst (trans_local Σ' Γ) k. Proof using Σ. @@ -1004,7 +1004,7 @@ Section Trans_Global. len. now rewrite context_assumptions_map. * now f_equal. Qed. - + Lemma trans_expand_lets_k Γ k t : trans Σ' (Ast.Env.expand_lets_k Γ k t) = expand_lets_k (trans_local Σ' Γ) k (trans Σ' t). Proof using Σ. @@ -1035,7 +1035,7 @@ Section Trans_Global. f_equal. now rewrite trans_subst. Qed. - + Lemma trans_lift_context n k Γ : trans_local Σ' (Ast.Env.lift_context n k Γ) = lift_context n k (trans_local Σ' Γ). @@ -1066,14 +1066,14 @@ Section Trans_Global. now rewrite (trans_subst_context [_]). rewrite IHΔ. f_equal. rewrite /trans_local map_app //. Qed. - + Lemma map_decl_subst_instance_set_binder_name i x y : - map_decl (subst_instance i) (set_binder_name x y) = + map_decl (subst_instance i) (set_binder_name x y) = set_binder_name x (map_decl (subst_instance i) y). Proof using Σ. now rewrite /map_decl /set_binder_name /=. Qed. - + Lemma map2_trans l l' : map2 (fun (x : aname) (y : BasicAst.context_decl Ast.term) => @@ -1084,8 +1084,8 @@ Section Trans_Global. eapply map2_ext. intros x y. rewrite /trans_decl. now destruct y; cbn. Qed. - - Lemma map_map_comm {A B B' C} (f : B -> C) (g : A -> B) (f' : B' -> C) (g' : A -> B') (l : list A) : + + Lemma map_map_comm {A B B' C} (f : B -> C) (g : A -> B) (f' : B' -> C) (g' : A -> B') (l : list A) : (forall x, f (g x) = f' (g' x)) -> map f (map g l) = map f' (map g' l). Proof. @@ -1117,7 +1117,7 @@ Section Trans_Global. let p' := trans_predicate ind mdecl' idecl' p'.(Ast.pparams) p'.(Ast.puinst) p'.(Ast.pcontext) p'.(Ast.preturn) in #|Ast.bcontext br| = #|Ast.Env.cstr_args cdecl| -> trans Σ' (ST.iota_red pars args bctx br) = - iota_red pars p' (List.map (trans Σ') args) + iota_red pars p' (List.map (trans Σ') args) (let br' := Ast.map_branch (trans Σ') br in trans_branch ind mdecl' cdecl' br'.(Ast.bcontext) br'.(Ast.bbody)). Proof using Σ. @@ -1135,7 +1135,7 @@ Section Trans_Global. change (map2 (fun (x : aname) (y : context_decl) => map_decl (subst_instance (Ast.puinst p)) (set_binder_name x y))) - with + with (map2 (fun (x : aname) (y : context_decl) => set_binder_name x (map_decl (subst_instance (Ast.puinst p)) y))). @@ -1238,21 +1238,21 @@ Section Trans_Global. Qed. Lemma cstr_branch_context_assumptions ci mdecl cdecl : - context_assumptions (cstr_branch_context ci mdecl cdecl) = + context_assumptions (cstr_branch_context ci mdecl cdecl) = context_assumptions cdecl.(cstr_args). Proof. rewrite /cstr_branch_context /expand_lets_ctx /expand_lets_k_ctx. now rewrite !context_assumptions_fold. Qed. - + Lemma Ast_cstr_branch_context_assumptions ci mdecl cdecl : - Ast.Env.context_assumptions (Ast.cstr_branch_context ci mdecl cdecl) = + Ast.Env.context_assumptions (Ast.cstr_branch_context ci mdecl cdecl) = Ast.Env.context_assumptions cdecl.(Ast.Env.cstr_args). Proof. rewrite /cstr_branch_context /expand_lets_ctx /expand_lets_k_ctx. now rewrite !Ast.Env.context_assumptions_fold. Qed. - + Lemma map2_set_binder_name_context_assumptions (l : list aname) (l' : Ast.Env.context) : #|l| = #|l'| -> Ast.Env.context_assumptions (map2 Ast.Env.set_binder_name l l') = Ast.Env.context_assumptions l'. @@ -1270,7 +1270,7 @@ Section Trans_Global. Hint Rewrite Ast_inst_case_context_length : len. Lemma Ast_inst_case_context_assumptions pars puinst ctx : - Ast.Env.context_assumptions (Ast.inst_case_context pars puinst ctx) = + Ast.Env.context_assumptions (Ast.inst_case_context pars puinst ctx) = Ast.Env.context_assumptions ctx. Proof. rewrite /Ast.inst_case_context. @@ -1280,7 +1280,7 @@ Section Trans_Global. Lemma case_branch_context_assumptions ci mdecl cdecl p br : #|Ast.bcontext br| = #|Ast.Env.cstr_args cdecl| -> - Ast.Env.context_assumptions (Ast.case_branch_context ci mdecl cdecl p br) = + Ast.Env.context_assumptions (Ast.case_branch_context ci mdecl cdecl p br) = Ast.Env.context_assumptions cdecl.(Ast.Env.cstr_args). Proof. intros. @@ -1288,8 +1288,8 @@ Section Trans_Global. rewrite map2_set_binder_name_context_assumptions; len. Qed. - Lemma declared_inductive_lookup {ind mdecl idecl} : - declared_inductive Σ' ind mdecl idecl -> + Lemma declared_inductive_lookup {ind mdecl idecl} : + declared_inductive Σ' ind mdecl idecl -> lookup_inductive Σ' ind = Some (mdecl, idecl). Proof. intros []. unfold lookup_inductive, lookup_minductive. @@ -1306,9 +1306,9 @@ Section Trans_Global. Qed. Lemma trans_inst_case_context pars puinst ctx : - trans_local Σ' (Ast.inst_case_context pars puinst ctx) = + trans_local Σ' (Ast.inst_case_context pars puinst ctx) = inst_case_context (map (trans Σ') pars) puinst (trans_local Σ' ctx). - Proof using Σ. + Proof using Σ. rewrite /Ast.inst_case_context /inst_case_context. now rewrite trans_subst_context map_rev trans_local_subst_instance. Qed. @@ -1346,7 +1346,7 @@ Section Trans_Global. now rewrite trans_expand_lets_ctx. } now rewrite trans_expand_lets_ctx. Qed. - + Lemma trans_ind_predicate_context (Γ : list aname) ind mdecl idecl : let mdecl':= trans_minductive_body Σ' mdecl in let idecl':= trans_one_ind_body Σ' idecl in @@ -1361,13 +1361,13 @@ Section Trans_Global. rewrite -trans_expand_lets_ctx. eapply All2_map_right. solve_all. Qed. - + Lemma trans_cstr_branch_context_alpha (Γ : list aname) ind mdecl cdecl : let mdecl' := trans_minductive_body Σ' mdecl in let cdecl' := trans_constructor_body Σ' cdecl in - All2 (fun x y => eq_binder_annot x (decl_name y)) Γ + All2 (fun x y => eq_binder_annot x (decl_name y)) Γ (Ast.cstr_branch_context ind mdecl cdecl) -> - All2 (fun x y => eq_binder_annot x (decl_name y)) Γ + All2 (fun x y => eq_binder_annot x (decl_name y)) Γ (cstr_branch_context ind mdecl' cdecl'). Proof using Σ. intros. @@ -1448,7 +1448,7 @@ Section Trans_Global. induction 1; cbn; constructor; auto. Qed. - Lemma OnOne2All_map2 {A B D} (P : D -> B -> B -> Type) + Lemma OnOne2All_map2 {A B D} (P : D -> B -> B -> Type) (f : B -> A -> D) (l : list A) (l' : list B) (l'' : list B) : #|l| = #|l'| -> OnOne2All P (map2 f l' l) l' l'' -> @@ -1473,7 +1473,7 @@ Section Trans_Global. Context (wfΣ : Typing.wf Σ). Context (wfΣ' : wf Σ'). - + Lemma wf_wf_decl_pred : Typing.on_global_env Typing.cumul_gen (fun Σ => WfAst.wf_decl_pred Σ) Σ. Proof. now eapply typing_wf_sigma. Qed. Hint Resolve wf_wf_decl_pred : wf. @@ -1567,18 +1567,18 @@ Section Trans_Global. eapply forall_decls_declared_inductive in isdecl; tea. rewrite trans_lookup_inductive. rewrite (declared_inductive_lookup isdecl). - constructor. cbn. + constructor. cbn. rewrite trans_local_app in IHX. rewrite inst_case_predicate_context_eq in IHX => //. eapply All2_length in hpctx; len in hpctx. eapply IHX => //. eapply All_app_inv => //. eapply declared_inductive_wf_case_predicate_context => //. - + - destruct a as [isdecl hci hpctx wfpar wfret wfc wfbrs]. eapply forall_decls_declared_inductive in isdecl; tea. rewrite trans_lookup_inductive (declared_inductive_lookup isdecl). - constructor. cbn. apply IHX => //. + constructor. cbn. apply IHX => //. - destruct a as [isdecl' hci hpctx lenpar wfpar wfret wfc wfbrs]. destruct (declared_inductive_inj isdecl isdecl'). @@ -1730,7 +1730,7 @@ Lemma trans_cumul_gen {cf} (Σ : Ast.Env.global_env_ext) pb Γ T U : Proof. intros wfΣ Σ' wfΣ'. induction 4. - - constructor. + - constructor. destruct pb. * eapply trans_eq_term in c; eauto. now rewrite global_ext_constraints_trans. @@ -1811,7 +1811,7 @@ Axiom cofix_guard_trans : Notation Swf_fix Σ def := (WfAst.wf Σ (dtype def) * WfAst.wf Σ (dbody def)). -Lemma trans_decompose_app {Σ t ind u l} : +Lemma trans_decompose_app {Σ t ind u l} : WfAst.wf Σ t -> let Σ' := trans_global_env Σ in AstUtils.decompose_app t = (Ast.tInd ind u, l) -> @@ -1836,10 +1836,10 @@ Qed. Lemma trans_decompose_prod_assum {Σ Σ'} ctx t : WfAst.wf Σ t -> let (ctx', t') := AstUtils.decompose_prod_assum ctx t in - decompose_prod_assum (trans_local Σ' ctx) (trans Σ' t) = + decompose_prod_assum (trans_local Σ' ctx) (trans Σ' t) = (trans_local Σ' ctx', trans Σ' t'). Proof. - intros wft; + intros wft; induction wft in ctx |- * using WfAst.term_wf_forall_list_ind ; cbn; try intros [= <- <-]; auto. - apply IHwft0. - apply IHwft1. @@ -1856,7 +1856,7 @@ Proof. - intros t. destruct a as [na [b|] ty]; simpl in *. rewrite /Ast.Env.mkProd_or_LetIn /=. * etransitivity. eapply IHΓ. split; intros []. - depelim w. intuition constructor; auto. split; auto. + depelim w. intuition constructor; auto. split; auto. depelim a. red in w. simpl in w. split; auto with wf. constructor; intuition auto. * etransitivity. eapply IHΓ => /=. split; intros []. depelim w. simpl in w1. split; [constructor|];auto. @@ -1912,7 +1912,7 @@ Qed. Lemma map_option_out_check_one_fix {Σ mfix} : let Σ' := trans_global_env Σ in All (fun def => (WfAst.wf Σ (dtype def) * WfAst.wf Σ (dbody def))) mfix -> - forall l, + forall l, map_option_out (map (fun x => ST.check_one_fix x) mfix) = Some l -> map_option_out (map (fun x => check_one_fix (map_def (trans Σ') (trans Σ') x)) mfix) = Some l. Proof. @@ -1941,7 +1941,7 @@ Qed. Lemma map_option_out_check_one_cofix {Σ mfix} : let Σ' := trans_global_env Σ in All (fun def => (WfAst.wf Σ (dtype def) * WfAst.wf Σ (dbody def))) mfix -> - forall l, + forall l, map_option_out (map (fun x => ST.check_one_cofix x) mfix) = Some l -> map_option_out (map (fun x => check_one_cofix (map_def (trans Σ') (trans Σ') x)) mfix) = Some l. Proof. @@ -1994,19 +1994,19 @@ Proof. destruct l; auto. now rewrite -trans_check_rec_kind. Qed. -Lemma trans_global_decl_universes Σ d : - Ast.universes_decl_of_decl d = +Lemma trans_global_decl_universes Σ d : + Ast.universes_decl_of_decl d = universes_decl_of_decl (trans_global_decl Σ d). Proof. destruct d; reflexivity. Qed. -Lemma trans_consistent_instance_ext {cf:checker_flags} Σ d u : +Lemma trans_consistent_instance_ext {cf:checker_flags} Σ d u : let Σ' := trans_global Σ in Ast.consistent_instance_ext Σ (Ast.universes_decl_of_decl d) u -> consistent_instance_ext Σ' (universes_decl_of_decl (trans_global_decl Σ' d)) u. Proof. - intros Σ'. + intros Σ'. unfold Ast.consistent_instance_ext, consistent_instance_ext. rewrite global_ext_levels_trans global_ext_constraints_trans. rewrite (trans_global_decl_universes Σ'). @@ -2062,15 +2062,15 @@ Proof. now rewrite PCUICUnivSubstitutionConv.subst_instance_app_ctx. Qed. -Lemma All2_map2_right {A B C} {l : list A} {l' : list B} (f : A -> B -> C) P : - All2 (fun x y => P x (f x y)) l l' -> +Lemma All2_map2_right {A B C} {l : list A} {l' : list B} (f : A -> B -> C) P : + All2 (fun x y => P x (f x y)) l l' -> All2 P l (map2 f l l'). Proof. induction 1; cbn; constructor; auto. Qed. -Lemma All2i_map2_right {A B C} {n} {l : list A} {l' : list B} (f : A -> B -> C) P : - All2i (fun n x y => P n x (f x y)) n l l' -> +Lemma All2i_map2_right {A B C} {n} {l : list A} {l' : list B} (f : A -> B -> C) P : + All2i (fun n x y => P n x (f x y)) n l l' -> All2i P n l (map2 f l l'). Proof. induction 1; cbn; constructor; auto. @@ -2095,8 +2095,8 @@ Lemma simpl_type_Case {H : checker_flags} {Σ : global_env_ext} {Γ} {ci : case_ eq_context_upto_names (bcontext br) (cstr_branch_context ci mdecl cdecl) * (let brctxty := case_branch_type ci mdecl idecl p br ptm i cdecl in - Σ;;; Γ,,, brctxty.1 |- bbody br : brctxty.2 × - Σ;;; Γ,,, brctxty.1 |- brctxty.2 : tSort ps)) 0 + Σ;;; Γ,,, brctxty.1 |- bbody br : brctxty.2 × + Σ;;; Γ,,, brctxty.1 |- brctxty.2 : tSort ps)) 0 (ind_ctors idecl) brs -> Σ;;; Γ |- tCase ci p c brs : mkApps ptm (indices ++ [c]). Proof. @@ -2180,7 +2180,7 @@ Proof. rewrite trans_mkApps trans_lift. f_equal. { rewrite /cdecl'; len. f_equal. rewrite /ptm' /ptm trans_it_mkLambda_or_LetIn // /p'0 /=. f_equal. - rewrite /bctx. + rewrite /bctx. rewrite [map _ (Ast.case_predicate_context _ _ _ _)](trans_case_predicate_context Σ ci mdecl idecl p) //. eapply All2_length in X. len in X. } rewrite map_app /=. f_equal. @@ -2220,7 +2220,7 @@ Local Hint Transparent Universe.t : trans. Local Hint Variables Transparent : trans. Ltac trans := try typeclasses eauto with trans. (* bug in Coq, typeclasses eauto tries exact with a quantified hypothesis starting with a let-in *) -Ltac simpl_let := +Ltac simpl_let := match goal with | [ H : let _ := _ in _ |- _ ] => progress (cbv zeta in H) end. @@ -2241,7 +2241,7 @@ Proof. all: try solve [ econstructor; trans ]. - eapply trans_wf_local; eauto. - + - rewrite trans_lift. eapply refine_type. eapply type_Rel; eauto. unfold trans_local. rewrite nth_error_map. rewrite H. reflexivity. @@ -2288,7 +2288,7 @@ Proof. eapply IHX1; cycle 1. 2:apply WfAst.wf_subst; try constructor; auto. 2:now inv wfAB. specialize (p X2). specialize (p0 X2). - eapply PCUICInversion.inversion_Prod in p as [s1 [s2 [HA [HB Hs]]]]; auto. + eapply PCUICInversion.inversion_Prod in p as [s1 [s2 [HA [HB Hs]]]]; auto. eapply (PCUICArities.isType_subst (Δ := [vass na (trans Σ' A)])); eauto. eapply subslet_ass_tip. eauto with pcuic. now exists s2. @@ -2318,20 +2318,20 @@ Proof. now apply (trans_consistent_instance_ext Σ (Ast.Env.InductiveDecl mdecl)). reflexivity. - - cbn; rewrite trans_mkApps; auto with wf trans. + - cbn; rewrite trans_mkApps; auto with wf trans. pose proof (forall_decls_declared_inductive _ _ _ _ _ _ isdecl). rewrite trans_lookup_inductive. rewrite (declared_inductive_lookup _ H4). rewrite trans_it_mkLambda_or_LetIn. rewrite -/(trans_local Σ' (Ast.case_predicate_context _ _ _ _)). have lenpctx : #|Ast.pcontext p| = S #|Ast.Env.ind_indices idecl|. - { eapply All2_length in X1; len in X1. } + { eapply All2_length in X1; len in X1. } rewrite (trans_case_predicate_context Σ) //. rewrite map_app. specialize (X6 X8). specialize (X4 X8). set (p' := trans_predicate _ _ _ _ _ _ _). - eapply (simpl_type_Case (p:=p') (ps:=ps)) => //. + eapply (simpl_type_Case (p:=p') (ps:=ps)) => //. + cbn. rewrite map2_map2_bias_left; len. eapply eq_binder_annots_eq. now eapply trans_ind_predicate_context. @@ -2373,7 +2373,7 @@ Proof. rewrite /forget_types map_map2 map2_cst; len. eapply eq_annots_cstr_branch_context. eapply All2_Forall2. eapply trans_cstr_branch_context_alpha; tea. - + eapply All2i_map2_right. eapply All2i_map. + + eapply All2i_map2_right. eapply All2i_map. eapply All2i_impl; tea. cbv beta. intros i cdecl br. set (brctxty := Ast.case_branch_type _ _ _ _ _ _ _). @@ -2388,7 +2388,7 @@ Proof. intros brctxty'. destruct (trans_case_branch_type Σ ci mdecl idecl cdecl i p br X1 eqann) as [eqctx eqbty]. rewrite [brctxty'.2]eqbty. - rewrite [brctxty'.1]eqctx. + rewrite [brctxty'.1]eqctx. clear eqctx eqbty. specialize (IHbod X8). specialize (IHty X8). rewrite trans_local_app in IHbod. @@ -2400,7 +2400,7 @@ Proof. eapply forall_decls_declared_projection in isdecl => //. destruct (typing_wf _ wfΣ _ _ _ X1) as [wfc wfind]. eapply WfAst.wf_mkApps_inv in wfind; auto. - rewrite trans_subst; auto with wf. + rewrite trans_subst; auto with wf. simpl. rewrite map_rev trans_subst_instance. eapply (type_Proj _ _ _ _ _ _ _ _ (Build_projection_body arity relevance (trans Σ' ty'))). eauto. rewrite trans_mkApps in X2; auto. rewrite map_length. @@ -2454,13 +2454,13 @@ Proof. now eapply TypingWf.typing_wf in Hs'. -- destruct decl; reflexivity. - - cbn. econstructor; cbn; eauto. + - cbn. econstructor; cbn; eauto. + rewrite trans_env_retroknowledge //. + now apply forall_decls_declared_constant. + move: X0; rewrite /Ast.Env.primitive_invariants /primitive_invariants. intros [s []]; exists s; split => //; destruct cdecl as [ty [?|] ?]; cbn in *; subst; auto => //. - - cbn. econstructor; cbn; eauto. + - cbn. econstructor; cbn; eauto. + rewrite trans_env_retroknowledge //. + now apply forall_decls_declared_constant. + move: X0; rewrite /Ast.Env.primitive_invariants /primitive_invariants. @@ -2469,33 +2469,33 @@ Proof. - assert (WfAst.wf Σ B). { now apply typing_wf in X2. } eapply type_Cumul; eauto. - eapply trans_cumulSpec_typed; eauto with trans. + eapply trans_cumulSpec_typed; eauto with trans. clear X. apply typing_all_wf_decl in wfΓ; auto. eapply typing_wf in X0; eauto. destruct X0. auto. - specialize (X1 X5). + specialize (X1 X5). now eapply validity in X1. specialize (X3 X5). now exists s. Qed. -Lemma Alli_map {A B} (P : nat -> B -> Type) n (f : A -> B) l : +Lemma Alli_map {A B} (P : nat -> B -> Type) n (f : A -> B) l : Alli (fun n x => P n (f x)) n l -> Alli P n (map f l). Proof. induction 1; constructor; auto. Qed. -Lemma trans_arities_context Σ m : - let Σ' := trans_global_env Σ in - trans_local Σ' (Ast.Env.arities_context (Ast.Env.ind_bodies m)) = +Lemma trans_arities_context Σ m : + let Σ' := trans_global_env Σ in + trans_local Σ' (Ast.Env.arities_context (Ast.Env.ind_bodies m)) = arities_context (map (trans_one_ind_body Σ') (Ast.Env.ind_bodies m)). Proof. - rewrite /trans_local /Ast.Env.arities_context rev_map_spec map_rev map_map_compose + rewrite /trans_local /Ast.Env.arities_context rev_map_spec map_rev map_map_compose /PCUICEnvironment.arities_context rev_map_spec map_map_compose /= //. Qed. -Lemma trans_subst_telescope Σ s k Γ : - let Σ' := trans_global_env Σ in - map (trans_decl Σ') (Ast.Env.subst_telescope s k Γ) = +Lemma trans_subst_telescope Σ s k Γ : + let Σ' := trans_global_env Σ in + map (trans_decl Σ') (Ast.Env.subst_telescope s k Γ) = subst_telescope (map (trans Σ') s) k (map (trans_decl Σ') Γ). Proof. rewrite /subst_telescope /Ast.Env.subst_telescope. @@ -2519,7 +2519,7 @@ Proof. rewrite closedn_ctx_snoc in H. now move/andP: H=>[]. cbn. rewrite map2_bias_left_length. rewrite closedn_ctx_snoc in H. move/andP: H=>[]. - + cbn. specialize (IHbctx _ _ H). cbn in IHbctx. @@ -2528,7 +2528,7 @@ Proof. eapply closed_decl rewrite closedn_ctx_ *) -Lemma closed_ind_predicate_context {cf} {Σ ind mdecl idecl} : +Lemma closed_ind_predicate_context {cf} {Σ ind mdecl idecl} : wf Σ -> declared_inductive Σ ind mdecl idecl -> closedn_ctx (context_assumptions mdecl.(ind_params)) (ind_predicate_context ind mdecl idecl). @@ -2538,7 +2538,7 @@ Proof. eapply PCUICClosedTyp.declared_minductive_closed. eapply decli. Qed. -Lemma All2_All_map2 {A B C} {P : A -> Type} (f : B -> C -> A) l l' : +Lemma All2_All_map2 {A B C} {P : A -> Type} (f : B -> C -> A) l l' : All2 (fun x y => P (f x y)) l l' -> All P (map2 f l l'). Proof. @@ -2549,7 +2549,7 @@ Lemma trans_closedn {cf} {Σ k t} : Typing.wf Σ -> wf (trans_global_env Σ) -> WfAst.wf Σ t -> - Ast.closedn k t -> + Ast.closedn k t -> closedn k (trans (trans_global_env Σ) t). Proof. intros wfΣ wfΣ' wf. induction wf using WfAst.term_wf_forall_list_ind in k |- *; cbn; auto. @@ -2558,7 +2558,7 @@ Proof. - eapply forall_decls_declared_inductive in H; tea. rewrite trans_lookup_inductive. rewrite (declared_inductive_lookup _ H). - destruct X0. + destruct X0. cbn. unfold test_predicate_k. cbn. unfold Ast.test_predicate. cbn. @@ -2596,8 +2596,8 @@ Proof. cbn. now rewrite context_assumptions_map. } rewrite map2_length; len. eauto. - unfold test_def; red in X. solve_all. - - unfold test_def; solve_all. -Qed. + - unfold test_def; solve_all. +Qed. From MetaCoq.PCUIC Require Import PCUICOnFreeVars. @@ -2619,7 +2619,7 @@ Proof. move/andP: H => [] cl0 cl1. move/andP: H0 => [] cl0' cl1'. len in cl1. len in cl1'. destruct p; constructor; cbn; auto; depelim X0; depelim X1; destruct w as []; destruct w0 as []. - + eapply trans_cumul_gen in eqt; tea. eapply (PCUICConversion.cumulAlgo_cumulSpec _ (pb:=Cumul)). eapply PCUICWellScopedCumulativity.into_ws_cumul_pb => //. @@ -2647,7 +2647,7 @@ Proof. now rewrite (All2_fold_length X). Qed. -Lemma wf_expand_lets Σ Γ t : +Lemma wf_expand_lets Σ Γ t : All (WfAst.wf_decl Σ) Γ -> WfAst.wf Σ t -> WfAst.wf Σ (Ast.Env.expand_lets Γ t). @@ -2658,7 +2658,7 @@ Proof. now eapply wf_extended_subst. Qed. -Lemma wf_expand_lets_ctx Σ Γ Δ : +Lemma wf_expand_lets_ctx Σ Γ Δ : All (WfAst.wf_decl Σ) Γ -> All (WfAst.wf_decl Σ) Δ -> All (WfAst.wf_decl Σ) (Ast.Env.expand_lets_ctx Γ Δ). @@ -2670,7 +2670,7 @@ Proof. eapply wf_extended_subst => //. Qed. -Lemma wf_ind_arities Σ mdecl : +Lemma wf_ind_arities Σ mdecl : All (wf_inductive_body Σ) (Ast.Env.ind_bodies mdecl) -> All (WfAst.wf_decl Σ) (Typing.ind_arities mdecl). Proof. @@ -2722,7 +2722,7 @@ Lemma trans_cstr_respects_variance {cf} Σ mdecl v cdecl : (Ast.Env.expand_lets_ctx (Ast.Env.ind_params mdecl) (Ast.Env.smash_context [] (Ast.Env.cstr_args cdecl)))))) -> All (fun x : Ast.term => - closedn (Ast.Env.context_assumptions (Ast.Env.cstr_args cdecl) + + closedn (Ast.Env.context_assumptions (Ast.Env.cstr_args cdecl) + Ast.Env.context_assumptions (Ast.Env.ind_params mdecl) + #|ST.ind_arities mdecl|) (trans Σ' (Ast.Env.expand_lets (Ast.Env.app_context (Ast.Env.ind_params mdecl) @@ -2775,7 +2775,7 @@ Proof. intros h. simpl in h. eapply (PCUICConversion.cumulAlgo_cumulSpec _ (pb:=Conv)). eapply PCUICWellScopedCumulativity.into_ws_cumul_pb; tea. - { move: clctx. + { move: clctx. rewrite smash_context_app_expand. rewrite -!(trans_smash_context _ []). rewrite -trans_expand_lets_ctx trans_ind_arities. @@ -2783,13 +2783,13 @@ Proof. move/(closed_ctx_on_free_vars xpred0). rewrite !Ast.Env.app_context_assoc. now rewrite on_free_vars_ctx_subst_instance. } - { eapply closedn_on_free_vars. len. move: a0. - rewrite /ST.ind_arities; len. + { eapply closedn_on_free_vars. len. move: a0. + rewrite /ST.ind_arities; len. rewrite !context_assumptions_map. rewrite trans_expand_lets trans_local_app. rewrite PCUICClosed.closedn_subst_instance //. } - { eapply closedn_on_free_vars. len. move: a0. - rewrite /ST.ind_arities; len. + { eapply closedn_on_free_vars. len. move: a0. + rewrite /ST.ind_arities; len. rewrite !context_assumptions_map. rewrite trans_expand_lets trans_local_app. rewrite PCUICClosed.closedn_subst_instance //. } } @@ -2854,7 +2854,7 @@ Proof. Qed. Lemma trans_type_local_ctx {cf} {Σ : Ast.Env.global_env_ext} Γ cs s (Σ' := trans_global Σ) : - (forall (Σ : Ast.Env.global_env_ext) + (forall (Σ : Ast.Env.global_env_ext) (Γ : Ast.Env.context) (t : Ast.term) (T : typ_or_sort_ Ast.term), Typing.wf Σ -> Typing.lift_typing Typing.typing Σ Γ t T -> @@ -2891,7 +2891,7 @@ Lemma trans_check_ind_sorts {cf} Σ udecl kn mdecl n idecl (idecl' := trans_one_ind_body Σ' idecl) : Typing.wf Σ -> wf Σ' -> - (forall (Σ : Ast.Env.global_env_ext) + (forall (Σ : Ast.Env.global_env_ext) (Γ : Ast.Env.context) (t : Ast.term) (T : typ_or_sort_ Ast.term), Typing.wf Σ -> Typing.lift_typing Typing.typing Σ Γ t T -> @@ -2903,7 +2903,7 @@ Lemma trans_check_ind_sorts {cf} Σ udecl kn mdecl n idecl forall (oni: Typing.on_ind_body Typing.cumul_gen (Typing.TemplateEnvTyping.lift_typing Typing.typing) (Σ, udecl) kn mdecl n idecl), ST.check_ind_sorts - (Typing.TemplateEnvTyping.lift_typing Typing.typing) + (Typing.TemplateEnvTyping.lift_typing Typing.typing) (Σ, Ast.Env.ind_universes mdecl) (Ast.Env.ind_params mdecl) (Ast.Env.ind_kelim idecl) (Ast.Env.ind_indices idecl) (ST.ind_cunivs oni) (Ast.Env.ind_sort idecl) -> @@ -2919,7 +2919,7 @@ Proof. unfold ST.check_ind_sorts, check_ind_sorts. cbn. destruct Universe.is_prop => //. destruct Universe.is_sprop => //. - intros []. split => //. + intros []. split => //. now rewrite -global_ext_constraints_trans in c. destruct indices_matter => //. now eapply trans_type_local_ctx in y. @@ -2932,27 +2932,27 @@ Lemma on_global_decl_wf {cf} {Σ : Ast.Env.global_env_ext} {kn d} : Proof. intros. eapply TypingWf.on_global_decl_impl; tea. intros. - destruct T. + destruct T. * eapply typing_wf; tea. * destruct X2 as [s Hs]. red. split => //. now eapply typing_wf in Hs; tea. Qed. -Lemma Alli_All_mix {A} {P : nat -> A -> Type} {Q} {n l} : +Lemma Alli_All_mix {A} {P : nat -> A -> Type} {Q} {n l} : Alli P n l -> All Q l -> Alli (fun n x => P n x × Q x) n l. Proof. induction 1; intros H; depelim H; constructor; intuition auto. Qed. Lemma trans_projs Σ kn n i mdecl : - map (trans (trans_global_env Σ)) + map (trans (trans_global_env Σ)) (Ast.Env.projs {| inductive_mind := kn; inductive_ind := n |} (Ast.Env.ind_npars mdecl) i) = projs {| inductive_mind := kn; inductive_ind := n |} (Ast.Env.ind_npars mdecl) i. Proof. induction i; cbn; auto. f_equal; auto. Qed. -Lemma closed_arities_context {cf} Σ m : +Lemma closed_arities_context {cf} Σ m : wf (trans_global_env Σ) -> All (fun idecl => on_type (PCUICEnvTyping.lift_typing typing) ((trans_global_env Σ, Ast.Env.ind_universes m) : global_env_ext_map) [] @@ -2963,7 +2963,7 @@ Proof. rewrite /ST.ind_arities /Ast.Env.arities_context rev_map_spec. induction 1. cbn. auto. cbn. rewrite map_app closedn_ctx_app /=. len. - apply/andP; split. + apply/andP; split. rewrite /test_decl /trans_decl /=. destruct p as [s hs]. now eapply subject_closed in hs. eapply closedn_ctx_upwards; tea. lia. @@ -2974,17 +2974,17 @@ Proof. destruct Σ as [univs Σ] . unfold trans_global_env; cbn -[trans_global_decls]. induction Σ => /= //. -Qed. +Qed. -Lemma trans_env_env_retroknowledge {Σ : Ast.Env.global_env} : +Lemma trans_env_env_retroknowledge {Σ : Ast.Env.global_env} : retroknowledge (trans_env_env (trans_global_env Σ)) = Ast.Env.retroknowledge Σ. Proof. destruct Σ as [univs Σ] . unfold trans_global_env; cbn -[trans_global_decls]. induction Σ => /= //. -Qed. +Qed. -Lemma env_eq (g g' : global_env) : +Lemma env_eq (g g' : global_env) : g.(universes) = g'.(universes) -> g.(declarations) = g'.(declarations) -> g.(retroknowledge) = g'.(retroknowledge) -> @@ -2993,19 +2993,19 @@ Proof. destruct g, g'; cbn. congruence. Qed. -Lemma trans_consistent_instance_ext_gen {cf:checker_flags} Σ udecl u : +Lemma trans_consistent_instance_ext_gen {cf:checker_flags} Σ udecl u : let Σ' := trans_global Σ in Ast.consistent_instance_ext Σ udecl u -> consistent_instance_ext Σ' udecl u. Proof. - intros Σ'. + intros Σ'. unfold Ast.consistent_instance_ext, consistent_instance_ext. rewrite global_ext_levels_trans global_ext_constraints_trans. trivial. Qed. Lemma trans_on_global_env `{checker_flags} Σ : - (forall (Σ : Ast.Env.global_env_ext) Γ t T, Typing.wf Σ -> + (forall (Σ : Ast.Env.global_env_ext) Γ t T, Typing.wf Σ -> Typing.lift_typing Typing.typing Σ Γ t T -> let Σ' := trans_global_env Σ in wf Σ' -> @@ -3019,9 +3019,9 @@ Proof. { now rewrite trans_env_env_universes. } cbn -[trans_global_env] in *. rewrite trans_env_env_universes /= /trans_global_env /=. - induction ond; simpl; constructor; auto. destruct o. constructor; auto. + induction ond; simpl; constructor; auto. destruct o. constructor; auto. - red in kn_fresh |- *. clear -kn_fresh. - induction kn_fresh; cbn; constructor; auto. + induction kn_fresh; cbn; constructor; auto. - simpl. subst udecl. clear -on_udecl_udecl. now erewrite trans_global_decl_universes in on_udecl_udecl. @@ -3077,8 +3077,8 @@ Proof. (arities_context (ind_bodies (trans_minductive_body (trans_global_env Σg) m))) (cstr_type (trans_constructor_body (trans_global_env Σg) x)). - { unfold cstr_type, Ast.Env.cstr_type in on_ctype |- *; simpl in *. red. - move: (X (Σg, Ast.Env.ind_universes m) (Ast.Env.arities_context (Ast.Env.ind_bodies m)) + { unfold cstr_type, Ast.Env.cstr_type in on_ctype |- *; simpl in *. red. + move: (X (Σg, Ast.Env.ind_universes m) (Ast.Env.arities_context (Ast.Env.ind_bodies m)) (Ast.Env.cstr_type x) Sort). rewrite trans_arities_context. intros H'. apply H' => //. } @@ -3090,10 +3090,10 @@ Proof. (cstr_concl (trans_minductive_body (trans_global_env Σg) m) n (trans_constructor_body (trans_global_env Σg) x))). { simpl; unfold cstr_type, Ast.Env.cstr_type in cstr_eq |- *; simpl in *. - rewrite cstr_eq. rewrite !trans_it_mkProd_or_LetIn. + rewrite cstr_eq. rewrite !trans_it_mkProd_or_LetIn. autorewrite with len. f_equal. f_equal. rewrite !trans_mkApps /cstr_concl /cstr_concl_head /= //. - f_equal; auto. simpl. + f_equal; auto. simpl. now rewrite /trans_local !map_length. rewrite map_app /=. f_equal. rewrite /trans_local !map_length. @@ -3109,12 +3109,12 @@ Proof. induction (Ast.Env.cstr_args x) in cs |- *; destruct cs; simpl; auto; destruct a as [na [b|] ty]; simpl in *; auto; split; intuition eauto; - specialize (foo - (Ast.Env.app_context (Ast.Env.app_context + specialize (foo + (Ast.Env.app_context (Ast.Env.app_context (Ast.Env.arities_context (Ast.Env.ind_bodies m)) (Ast.Env.ind_params m)) c)); rewrite /trans_local !map_app in foo. - now eapply (foo ty Sort). + now eapply (foo ty Sort). now apply (foo b (Typ ty)). now apply (foo ty Sort). now apply (foo b (Typ ty)). @@ -3127,8 +3127,8 @@ Proof. rewrite -trans_arities_context. induction 1; simpl; constructor; auto; have foo := (X (Σg, Ast.Env.ind_universes m) _ _ _ X0); - specialize (foo (Ast.Env.app_context (Ast.Env.app_context - (Ast.Env.arities_context (Ast.Env.ind_bodies m)) + specialize (foo (Ast.Env.app_context (Ast.Env.app_context + (Ast.Env.arities_context (Ast.Env.ind_bodies m)) (Ast.Env.ind_params m)) (Ast.Env.cstr_args x))); rewrite /trans_local !map_app in foo. now apply (foo i (Typ t)). @@ -3172,14 +3172,14 @@ Proof. generalize (trans_destArity Σg [] _ wfty wfΣg). destruct Ast.destArity as [[args s]|] => /= -> //. len. now rewrite context_assumptions_map. } - { cbn. constructor 3. + { cbn. constructor 3. rewrite trans_subst in IHp. apply IHp. move/WfAst.wf_inv: wfty => /= [[wfb wfty] wft]. eapply WfAst.wf_subst; auto. } { cbn -[Σ']. move/WfAst.wf_inv: wfty => /= [wfty wft]. constructor 4. len. eapply trans_closedn => //. - now apply IHp. } + now apply IHp. } { cbn. now apply IHon_ctype_positive. } + intros v indv. specialize (on_ctype_variance _ indv). @@ -3230,7 +3230,7 @@ Proof. rewrite context_assumptions_map. rewrite -[trans_local _ _ ++ _]trans_local_app -(trans_smash_context _ []) nth_error_map. rewrite /Ast.Env.app_context. destruct nth_error => // /=. - rewrite /trans_projection_body /=. + rewrite /trans_projection_body /=. move=> [] /= hb -> ->. cbn -[Σg]. split => //. rewrite trans_subst trans_inds. cbn -[Σg]. f_equal. rewrite trans_subst trans_lift. f_equal. now rewrite trans_projs. @@ -3255,7 +3255,7 @@ Proof. move=> [univs' [i [i' []]]] vu cu cu' hl. exists univs', i, i'; split => //. all:change (trans_env_env (trans_global_env Σg), univs') with (global_env_ext_map_global_env_ext (trans_global (Σg, univs'))); - now eapply trans_consistent_instance_ext_gen. + now eapply trans_consistent_instance_ext_gen. Qed. Lemma template_to_pcuic_env {cf} Σ : Template.Typing.wf Σ -> wf (trans_global_env Σ). diff --git a/pcuic/theories/TemplateToPCUICExpanded.v b/pcuic/theories/TemplateToPCUICExpanded.v index 0b84862c0..4747565cb 100644 --- a/pcuic/theories/TemplateToPCUICExpanded.v +++ b/pcuic/theories/TemplateToPCUICExpanded.v @@ -3,14 +3,14 @@ From Coq Require Import ssreflect. From MetaCoq.Template Require Import config utils. From MetaCoq.Template Require Ast TypingWf WfAst TermEquality EtaExpand TemplateProgram. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCumulativity - PCUICLiftSubst PCUICEquality PCUICReduction + PCUICLiftSubst PCUICEquality PCUICReduction PCUICUnivSubst PCUICTyping PCUICGlobalEnv TemplateToPCUIC - PCUICWeakeningConv PCUICWeakeningTyp PCUICSubstitution PCUICGeneration + PCUICWeakeningConv PCUICWeakeningTyp PCUICSubstitution PCUICGeneration PCUICCasesContexts TemplateToPCUICCorrectness PCUICEtaExpand PCUICProgram. Tactic Notation "wf_inv" ident(H) simple_intropattern(p) := -(eapply WfAst.wf_inv in H; progress cbn in H; try destruct H as p) || +(eapply WfAst.wf_inv in H; progress cbn in H; try destruct H as p) || (apply WfAst.wf_mkApps_napp in H; [|easy]; try destruct H as p). Local Hint Constructors expanded : expanded. @@ -22,7 +22,7 @@ Lemma expanded_context_map2_bias_left Σ n bctx ctx : (map2_bias_left set_binder_name dummy_decl bctx ctx). Proof. unfold expanded_context. - intros hl. + intros hl. rewrite map2_map2_bias_left //. intros [a]. sq. induction a in bctx, hl |- *; try econstructor; auto. @@ -53,14 +53,14 @@ Proof. intros exp; induction exp; cbn => //. destruct decl as [kn d]; cbn. destruct (eqb_spec c kn). intros [= ->]. - subst c. eexists. split ; [|exact H]. sq. red. split => //. cbn. + subst c. eexists. split ; [|exact H]. sq. red. split => //. cbn. eexists. cbn. instantiate (1:= [_]); reflexivity. intros hl; destruct (IHexp hl). exists x. intuition auto. - sq. eapply extends_decls_trans; tea. + sq. eapply extends_decls_trans; tea. split => //. now exists [(kn, d)]. Qed. -Lemma declared_constructor_expanded {Σ c mdecl idecl cdecl} : +Lemma declared_constructor_expanded {Σ c mdecl idecl cdecl} : expanded_global_env Σ -> declared_constructor Σ c mdecl idecl cdecl -> exists Σ', ∥ extends_decls Σ' Σ ∥ /\ expanded_minductive_decl Σ' mdecl /\ expanded_constructor_decl Σ' mdecl cdecl. @@ -68,23 +68,23 @@ Proof. intros exp [[decli hnth] hnth']. eapply declared_minductive_expanded in decli. destruct decli as [Σ' [ext exp']]. exists Σ'; split => //. split => //. - destruct exp' as [hp hb]. solve_all. + destruct exp' as [hp hb]. solve_all. eapply nth_error_all in hb; tea. destruct hb as [hb]. solve_all. eapply nth_error_all in hb; tea. auto. Qed. -Lemma expanded_extended_subst {Σ Γ Δ} : - expanded_context Σ Γ Δ -> +Lemma expanded_extended_subst {Σ Γ Δ} : + expanded_context Σ Γ Δ -> forall n, Forall (expanded Σ (repeat 0 (n + context_assumptions Δ) ++ Γ)) (extended_subst Δ n). Proof. intros [a]; induction a. cbn. constructor. - cbn. destruct d as [na [b|] ty]; cbn in *. constructor; auto. + cbn. destruct d as [na [b|] ty]; cbn in *. constructor; auto. { cbn. eapply (expanded_subst _ _ 0 _ []) => //. cbn. rewrite -/(repeat _ _). specialize (IHa n). solve_all. - len. rewrite repeat_app Nat.add_comm. + len. rewrite repeat_app Nat.add_comm. eapply expanded_lift. 1-2:now len; rewrite !repeat_length. now depelim p. } constructor; auto. @@ -138,7 +138,7 @@ Qed. Implicit Types (cf : checker_flags). -Lemma expanded_weakening {cf} {Σ Σ' Γ t} : +Lemma expanded_weakening {cf} {Σ Σ' Γ t} : wf Σ' -> extends_decls Σ Σ' -> expanded Σ Γ t -> expanded Σ' Γ t. Proof. intros wfΣ ext. @@ -151,7 +151,7 @@ Proof. eapply weakening_env_declared_constructor; tea. now eapply extends_decls_extends. Qed. -Lemma expanded_context_weakening {cf} {Σ Σ' Γ t} : +Lemma expanded_context_weakening {cf} {Σ Σ' Γ t} : wf Σ' -> extends_decls Σ Σ' -> expanded_context Σ Γ t -> expanded_context Σ' Γ t. Proof. intros wfΣ ext. @@ -175,7 +175,7 @@ Proof. unfold cstr_branch_context. epose proof (expanded_let_expansion hp (t:=(subst_context (inds (inductive_mind ind) (abstract_instance (ind_universes mdecl)) - (ind_bodies mdecl)) #|ind_params mdecl| + (ind_bodies mdecl)) #|ind_params mdecl| (cstr_args cdecl)))). rewrite !app_nil_r in H. forward H. epose proof (expanded_context_subst (Γ := []) (Δ' := repeat 0 #|ind_bodies mdecl|)). @@ -197,7 +197,7 @@ Proof with eauto using expanded. - wf_inv wf ?. eapply expanded_tRel with (args := []). eauto. lia. econstructor. - wf_inv wf [[[]]]. eapply expanded_tRel. eauto. len. solve_all. - wf_inv wf [[[]]]. econstructor. solve_all. - - wf_inv wf []. cbn. eapply expanded_mkApps with (args := [_]); cbn... econstructor. + - wf_inv wf []. cbn. eapply expanded_mkApps with (args := [_]); cbn... econstructor. eapply expanded_tRel with (args := []). reflexivity. lia. econstructor. - try now (wf_inv wf [[]]; eauto using expanded). - wf_inv wf [[[]]]. @@ -241,16 +241,16 @@ Proof with eauto using expanded. Qed. -Lemma wf_cons_inv {cf} Σ' (Σ : global_declarations) d : +Lemma wf_cons_inv {cf} Σ' (Σ : global_declarations) d : wf (set_declarations Σ' (d :: Σ)) -> wf (set_declarations Σ' Σ). Proof. intros []. split => //. now depelim o0. Qed. -Lemma template_wf_cons_inv {cf} univs retro (Σ : Ast.Env.global_declarations) d : - Typing.wf {| Ast.Env.universes := univs; Ast.Env.declarations := d :: Σ; +Lemma template_wf_cons_inv {cf} univs retro (Σ : Ast.Env.global_declarations) d : + Typing.wf {| Ast.Env.universes := univs; Ast.Env.declarations := d :: Σ; Ast.Env.retroknowledge := retro |} -> - let Σ' := {| Ast.Env.universes := univs; Ast.Env.declarations := Σ; + let Σ' := {| Ast.Env.universes := univs; Ast.Env.declarations := Σ; Ast.Env.retroknowledge := retro |} in Typing.wf Σ' × Typing.on_global_decl Typing.cumul_gen (WfAst.wf_decl_pred) (Σ', Ast.universes_decl_of_decl d.2) d.1 d.2 × ST.on_udecl univs (Ast.universes_decl_of_decl d.2). @@ -264,10 +264,10 @@ Proof. cbn. split => //. Qed. -Lemma trans_global_env_cons univs retro (Σ : Ast.Env.global_declarations) decl : - trans_global_env {| S.Env.universes := univs; S.Env.declarations := decl :: Σ; S.Env.retroknowledge := retro |} = - let Σ' := trans_global_env {| S.Env.universes := univs; S.Env.declarations := Σ; S.Env.retroknowledge := retro |} in - add_global_decl Σ' (decl.1, trans_global_decl Σ' decl.2). +Lemma trans_global_env_cons univs retro (Σ : Ast.Env.global_declarations) decl : + trans_global_env {| S.Env.universes := univs; S.Env.declarations := decl :: Σ; S.Env.retroknowledge := retro |} = + let Σ' := trans_global_env {| S.Env.universes := univs; S.Env.declarations := Σ; S.Env.retroknowledge := retro |} in + add_global_decl Σ' (decl.1, trans_global_decl Σ' decl.2). Proof. reflexivity. Qed. Arguments trans_global_env : simpl never. @@ -281,7 +281,7 @@ Proof. Qed. Lemma All_fold_All_mix_left (P : S.Env.context -> S.Env.context_decl -> Type) (Q : S.Env.context_decl -> Type) ctx : - All_fold P ctx -> + All_fold P ctx -> All Q ctx -> All_fold (fun Γ d => Q d × P Γ d) ctx. Proof. @@ -289,10 +289,10 @@ Proof. depelim X0. constructor; auto. Qed. -Lemma expanded_trans_local {cf} {Σ} {wfΣ : Typing.wf Σ} Γ ctx : +Lemma expanded_trans_local {cf} {Σ} {wfΣ : Typing.wf Σ} Γ ctx : expanded_global_env (trans_global_env Σ) -> All (WfAst.wf_decl Σ) ctx -> - EtaExpand.expanded_context Σ Γ ctx -> + EtaExpand.expanded_context Σ Γ ctx -> expanded_context (trans_global_env Σ) Γ (trans_local (trans_global_env Σ) ctx). Proof. rewrite /expanded_context. @@ -300,13 +300,13 @@ Proof. unfold trans_local. eapply All_fold_map. eapply All_fold_All_mix_left in a; tea. - eapply All_fold_impl; tea; cbv beta; intros ??; cbn; unfold WfAst.wf_decl; + eapply All_fold_impl; tea; cbv beta; intros ??; cbn; unfold WfAst.wf_decl; intros [wf Hd]; revert Hd wf; intros []; intros []; constructor; len. eapply trans_expanded in H; auto. Qed. Lemma wf_context_sorts {cf} {Σ ctx ctx' cunivs} {wfΣ : Typing.wf_ext Σ} : - Typing.sorts_local_ctx WfAst.wf_decl_pred Σ ctx ctx' cunivs -> + Typing.sorts_local_ctx WfAst.wf_decl_pred Σ ctx ctx' cunivs -> All (WfAst.wf_decl Σ) ctx'. Proof. induction ctx' in cunivs |- *; cbn; auto. @@ -315,12 +315,12 @@ Proof. destruct cunivs => //. intros [? []]. constructor; eauto. constructor; cbn; eauto. Qed. - + Lemma expanded_trans_global_env {cf} Σ {wfΣ : Typing.wf_ext Σ} : EtaExpand.expanded_global_env Σ -> expanded_global_env (trans_global_env Σ). -Proof. - destruct Σ as [[univs Σ] udecl]. +Proof. + destruct Σ as [[univs Σ] udecl]. cbn -[trans_global_env]. unfold EtaExpand.expanded_global_env; cbn -[trans_global_env]. intros etaenv; induction etaenv. - constructor; auto. diff --git a/pcuic/theories/TemplateToPCUICWcbvEval.v b/pcuic/theories/TemplateToPCUICWcbvEval.v index 7bf7b3b37..efca51296 100644 --- a/pcuic/theories/TemplateToPCUICWcbvEval.v +++ b/pcuic/theories/TemplateToPCUICWcbvEval.v @@ -23,7 +23,7 @@ From MetaCoq.Template Require Import TypingWf WcbvEval. From MetaCoq.PCUIC Require Import PCUICCSubst PCUICCanonicity PCUICWcbvEval. Tactic Notation "wf_inv" ident(H) simple_intropattern(p) := - (eapply WfAst.wf_inv in H; progress cbn in H; try destruct H as p) || + (eapply WfAst.wf_inv in H; progress cbn in H; try destruct H as p) || (apply WfAst.wf_mkApps_napp in H; [|easy]; try destruct H as p). Lemma eval_mkApps_inv Σ f args v : @@ -59,7 +59,7 @@ Proof. Qed. Lemma list_length_rev_ind {A} (P : list A -> Type) (p0 : P []) - (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (Γ ++ [d])) + (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (Γ ++ [d])) Γ : P Γ. Proof. generalize (le_n #|Γ|). @@ -68,7 +68,7 @@ Proof. destruct Γ using rev_case; [|simpl; intros; elimtype False; try lia]. cbn. intros; exact p0. len in H. intros. - destruct Γ using rev_case; simpl in *. + destruct Γ using rev_case; simpl in *. apply p0. apply pS. intros. apply IHn. len in H. Qed. @@ -113,7 +113,7 @@ Proof. now specialize (IHargs _ _ _ X evv). Qed. -Lemma csubst_mkApps a k f l : +Lemma csubst_mkApps a k f l : csubst a k (mkApps f l) = mkApps (csubst a k f) (map (csubst a k) l). Proof. induction l in f |- *; cbn; auto. @@ -121,9 +121,9 @@ Proof. now cbn. Qed. -Ltac dest_lookup := +Ltac dest_lookup := destruct TransLookup.lookup_inductive as [[mdecl idecl]|]. - + Lemma trans_csubst {cf} Σ a k b : Typing.wf Σ -> let Σ' := trans_global_env Σ in @@ -133,7 +133,7 @@ Lemma trans_csubst {cf} Σ a k b : Proof. intros wfΣ Σ' wfΣ' wfa. revert wfa k. - induction b using Template.Induction.term_forall_list_ind; simpl; intros; try congruence; + induction b using Template.Induction.term_forall_list_ind; simpl; intros; try congruence; try solve [repeat (f_equal; eauto)]. - cbn. destruct (k ?= n); auto. @@ -145,7 +145,7 @@ Proof. dest_lookup; cbn; f_equal; auto. unfold trans_predicate, map_predicate_k; cbn. f_equal; auto. solve_list. - + rewrite map2_bias_left_length. + + rewrite map2_bias_left_length. now rewrite e. + rewrite map_map2 !PCUICUnivSubstitutionConv.map2_map_r. clear -wfa X0. cbn. @@ -203,9 +203,9 @@ Proof. eapply value_final. now eapply eval_to_value in IHargs. rewrite -(All2_length a). lia. Qed. - -Lemma eval_value_cong Σ f x y res : - value Σ f -> + +Lemma eval_value_cong Σ f x y res : + value Σ f -> eval Σ x y -> eval Σ (tApp f y) res -> eval Σ (tApp f x) res. @@ -225,8 +225,8 @@ Proof. - now cbn in i. Qed. -Lemma eval_mkApps_value_cong Σ f x y res : - value Σ f -> +Lemma eval_mkApps_value_cong Σ f x y res : + value Σ f -> All2 (eval Σ) x y -> eval Σ (mkApps f y) res -> eval Σ (mkApps f x) res. @@ -252,7 +252,7 @@ Lemma eval_mkApps_fix {Σ : global_env} {f mfix idx argsv args' argsv' fn res na All2 (eval Σ) args' argsv' -> cunfold_fix mfix idx = Some (narg, fn) -> narg < #|argsv| + #|args'| -> - eval Σ (mkApps (mkApps fn argsv) argsv') res -> + eval Σ (mkApps (mkApps fn argsv) argsv') res -> eval Σ (mkApps f args') res. Proof. revert argsv argsv' res. induction args' using rev_ind; cbn; intros argsv argsv' res. @@ -291,7 +291,7 @@ Qed. Lemma wf_csubst Σ t k u : WfAst.wf Σ t -> WfAst.wf Σ u -> WfAst.wf Σ (WcbvEval.csubst t k u). Proof. intros wfts wfu. - induction wfu in k using WfAst.term_wf_forall_list_ind; simpl; intros; + induction wfu in k using WfAst.term_wf_forall_list_ind; simpl; intros; try solve[econstructor; cbn in *; eauto; solve_all]. - destruct Nat.compare => //; constructor. @@ -332,7 +332,7 @@ Proof. Qed. Lemma trans_fix_subst Σ mfix : - fix_subst (map (map_def (trans (trans_global_env Σ)) (trans (trans_global_env Σ))) mfix) = + fix_subst (map (map_def (trans (trans_global_env Σ)) (trans (trans_global_env Σ))) mfix) = map (trans (trans_global_env Σ)) (Typing.fix_subst mfix). Proof. unfold Typing.fix_subst, fix_subst. @@ -341,7 +341,7 @@ Proof. Qed. Lemma trans_cofix_subst Σ mfix : - cofix_subst (map (map_def (trans (trans_global_env Σ)) (trans (trans_global_env Σ))) mfix) = + cofix_subst (map (map_def (trans (trans_global_env Σ)) (trans (trans_global_env Σ))) mfix) = map (trans (trans_global_env Σ)) (Typing.cofix_subst mfix). Proof. unfold Typing.cofix_subst, cofix_subst. @@ -350,7 +350,7 @@ Proof. Qed. Lemma wf_cunfold_fix {cf} {Σ mfix idx narg fn} : - Typing.wf Σ -> + Typing.wf Σ -> All (fun def : def Ast.term => Swf_fix Σ def) mfix -> WcbvEval.cunfold_fix mfix idx = Some (narg, fn) -> WfAst.wf Σ fn. @@ -360,12 +360,12 @@ Proof. destruct nth_error eqn:hnth => //. intros [= <- <-]. eapply wf_substl. now eapply wf_fix_subst. - eapply nth_error_all in a; tea. cbn in a. + eapply nth_error_all in a; tea. cbn in a. now destruct a. Qed. Lemma wf_cunfold_cofix {cf} {Σ mfix idx narg fn} : - Typing.wf Σ -> + Typing.wf Σ -> All (fun def : def Ast.term => Swf_fix Σ def) mfix -> WcbvEval.cunfold_cofix mfix idx = Some (narg, fn) -> WfAst.wf Σ fn. @@ -375,12 +375,12 @@ Proof. destruct nth_error eqn:hnth => //. intros [= <- <-]. eapply wf_substl. now eapply wf_cofix_subst. - eapply nth_error_all in a; tea. cbn in a. + eapply nth_error_all in a; tea. cbn in a. now destruct a. Qed. Lemma trans_cunfold_fix {cf} {Σ mfix idx narg fn} : - Typing.wf Σ -> + Typing.wf Σ -> wf (trans_global_env Σ) -> All (fun def : def Ast.term => Swf_fix Σ def) mfix -> WcbvEval.cunfold_fix mfix idx = Some (narg, fn) -> @@ -400,7 +400,7 @@ Proof. Qed. Lemma trans_cunfold_cofix {cf} {Σ mfix idx narg fn} : - Typing.wf Σ -> + Typing.wf Σ -> wf (trans_global_env Σ) -> All (fun def : def Ast.term => Swf_fix Σ def) mfix -> WcbvEval.cunfold_cofix mfix idx = Some (narg, fn) -> @@ -430,7 +430,7 @@ Proof. now rewrite Sfst_decompose_app_rec. Qed. -Lemma eval_mkApps_cong Σ f args : +Lemma eval_mkApps_cong Σ f args : value Σ f -> All (value Σ) args -> ~~ (isLambda f || isFixApp f || isArityHead f || isConstructApp f || isPrimApp f) -> eval Σ (mkApps f args) (mkApps f args). @@ -492,7 +492,7 @@ Proof. eapply wf_csubst; eauto. specialize (IHev1 f'). now wf_inv IHev1 []. - wf_inv wf [[hb0 ht] hb1]. eapply IHev2. - eapply wf_csubst; eauto. + eapply wf_csubst; eauto. - wf_inv wf a. eapply IHev. eapply WfAst.wf_subst_instance. eapply declared_constant_wf in H. @@ -502,10 +502,10 @@ Proof. - eapply IHev2. wf_inv wf [mdecl' [idecl' []]]. destruct (declared_inductive_inj d (proj1 H0)). subst mdecl' idecl'. - rewrite /Typing.iota_red. + rewrite /Typing.iota_red. eapply All2_nth_error in a1; tea. 2:{ apply H0. } - eapply WfAst.wf_subst. + eapply WfAst.wf_subst. * eapply All_rev, All_skipn. specialize (IHev1 w0). now wf_inv IHev1 []. @@ -531,7 +531,7 @@ Proof. eapply All_app_inv => //. eapply All2_All_mix_left in X0; tea. eapply All2_All_right; tea; cbv beta; intuition auto. - + - wf_inv wf [Hf Hargs]. specialize (IHev Hf). wf_inv IHev [Hfix hargs]. @@ -559,7 +559,7 @@ Proof. - wf_inv wf [hf ha]. apply WfAst.wf_mkApps => //. constructor. solve_all. - + - wf_inv wf [[[hf ?]] ha]. eapply WfAst.wf_mkApps; eauto. eapply All2_All_mix_left in X0; tea. @@ -570,7 +570,7 @@ Qed. Lemma value_mkApps_tFix Σ mfix idx args rarg fn : cunfold_fix mfix idx = Some (rarg, fn) -> - #|args| <= rarg -> + #|args| <= rarg -> All (value Σ) args -> value Σ (mkApps (tFix mfix idx) args). Proof. @@ -590,12 +590,12 @@ Proof. intros Σ' wfΣ' wf ev. move: wf. induction ev using eval_evals_ind; intros wf; cbn -[Σ']. - + - wf_inv wf [[[napp argl] wff] wfa]. dependent elimination wfa as [All_cons (l:=l) wfx wfl]. cbn [trans]. rewrite trans_mkApps in IHev3. - cbn -[Σ']. + cbn -[Σ']. specialize (IHev1 wff). specialize (IHev2 wfx). cbn -[Σ'] in IHev1. pose proof (eval_wf wfx ev2). @@ -606,14 +606,14 @@ Proof. rewrite trans_csubst // in evf'. pose proof (eval_beta _ _ _ _ _ _ _ _ IHev1 IHev2 evf'). eapply eval_mkApps; tea. - + - wf_inv wf [[hb0 ht] hb1]. forward IHev1 by auto. pose proof (eval_wf hb0 ev1). forward IHev2. { eapply wf_csubst; eauto. } rewrite trans_csubst in IHev2; tea. econstructor; tea. - + - econstructor. eapply forall_decls_declared_constant; tea. rewrite /trans_constant_body H0 /=. reflexivity. @@ -650,8 +650,8 @@ Proof. rewrite PCUICCases.map2_set_binder_name_context_assumptions. len. len. now rewrite context_assumptions_map. } forward IHev2. - { rewrite /Typing.iota_red. - eapply WfAst.wf_subst. + { rewrite /Typing.iota_red. + eapply WfAst.wf_subst. * eapply All_rev, All_skipn. eapply eval_wf in ev1; tea. now wf_inv ev1 []. @@ -669,7 +669,7 @@ Proof. - wf_inv wf hdiscr. cbn in *; eapply eval_proj; tea. * eapply forall_decls_declared_projection in H; tea. - * rewrite trans_mkApps in IHev1. + * rewrite trans_mkApps in IHev1. now eapply IHev1. * cbn. len. rewrite H0 /WcbvEval.cstr_arity. f_equal. now rewrite context_assumptions_map. @@ -683,7 +683,7 @@ Proof. eapply WfAst.wf_mkApps_napp in wf as []; tea. specialize (IHev1 w). rewrite trans_mkApps /= in IHev1. - eapply eval_wf in ev1; tea. + eapply eval_wf in ev1; tea. eapply WfAst.wf_mkApps_napp in ev1 as [] => //. wf_inv w0 H. have wffn : WfAst.wf Σ fn. @@ -724,7 +724,7 @@ Proof. eapply All_map, All2_All_right; tea; cbv beta. { intuition auto. eapply eval_to_value; tea. } now wf_inv w0 x. - + - wf_inv wf [mdecl' [idecl' [decli ?]]]. pose proof (forall_decls_declared_inductive _ _ _ _ _ _ decli) as decli'; tea. rewrite trans_lookup_inductive. @@ -732,9 +732,9 @@ Proof. assert (w1 : WfAst.wf Σ (Ast.mkApps (Ast.tCoFix mfix idx) args)) by (eapply eval_wf; eauto). eapply WfAst.wf_mkApps_napp in w1 as []; [|easy]. - wf_inv w1 x. + wf_inv w1 x. eapply eval_cofix_case. - eapply trans_cunfold_cofix; tea. + eapply trans_cunfold_cofix; tea. rewrite trans_mkApps in IHev1. eapply IHev1. eauto. rewrite /= trans_lookup_inductive (declared_inductive_lookup _ decli') trans_mkApps in IHev2. apply IHev2. @@ -791,7 +791,7 @@ Proof. eapply isArityHead_mkApps. destruct args => //. rewrite isConstructApp_mkApps //. rewrite isPrimApp_mkApps //. - + - eapply eval_atom. destruct t => //. Qed. diff --git a/pcuic/theories/Typing/PCUICClosedTyp.v b/pcuic/theories/Typing/PCUICClosedTyp.v index 27553e428..ae6165cb9 100644 --- a/pcuic/theories/Typing/PCUICClosedTyp.v +++ b/pcuic/theories/Typing/PCUICClosedTyp.v @@ -1,15 +1,15 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import Morphisms. +From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction - PCUICLiftSubst PCUICUnivSubst PCUICSigmaCalculus PCUICClosed + PCUICLiftSubst PCUICUnivSubst PCUICSigmaCalculus PCUICClosed PCUICOnFreeVars PCUICTyping PCUICReduction PCUICGlobalEnv PCUICWeakeningEnvConv PCUICClosedConv PCUICWeakeningEnvTyp. Require Import ssreflect ssrbool. From Equations Require Import Equations. -Lemma declared_projection_closed_ind {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ}{mdecl idecl cdecl p pdecl} : +Lemma declared_projection_closed_ind {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ}{mdecl idecl cdecl p pdecl} : declared_projection Σ p mdecl idecl cdecl pdecl -> Forall_decls_typing (fun _ (Γ : context) (t T : term) => @@ -27,8 +27,8 @@ Proof. destruct onp as [_ onp]. red in onp. destruct (nth_error (smash_context [] _) _) eqn:Heq'; try contradiction. - destruct onp as [onna onp]. rewrite {}onp. - pose proof (onConstructors oib) as onc. + destruct onp as [onna onp]. rewrite {}onp. + pose proof (onConstructors oib) as onc. red in onc. rewrite Heq in onc. inv onc. clear X1. eapply on_cargs in X. simpl. @@ -49,7 +49,7 @@ Proof. red in onpars. eapply All_local_env_Pclosed in onpars. eapply (Alli_impl (Q:=fun i d => closed_decl (#|ind_params mdecl| + i + #|arities_context (ind_bodies mdecl)|) d)) in args. - 2:{ intros n x. rewrite app_context_length. + 2:{ intros n x. rewrite app_context_length. intros H; eapply closed_decl_upwards; eauto. lia. } eapply (Alli_shiftn (P:=fun i d => closed_decl (i + #|arities_context (ind_bodies mdecl)|) d)) in args. rewrite Nat.add_0_r in args. @@ -85,7 +85,7 @@ Proof. destruct X2 as [s0 Hs0]. simpl. rtoProp; intuition. Qed. -Lemma declared_minductive_closed_ind {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ}{mdecl mind} : +Lemma declared_minductive_closed_ind {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ}{mdecl mind} : Forall_decls_typing (fun (_ : global_env_ext) (Γ : context) (t T : term) => closedn #|Γ| t && closedn #|Γ| T) Σ -> @@ -94,15 +94,15 @@ Lemma declared_minductive_closed_ind {cf:checker_flags} {Σ : global_env} {wfΣ Proof. intros HΣ decl. pose proof (declared_decl_closed_ind decl) as decl'. - specialize (decl' HΣ). + specialize (decl' HΣ). red in decl'. unfold closed_inductive_decl. apply andb_and. split. apply onParams in decl'. now apply closedn_All_local_env in decl'; auto. apply onInductives in decl'. eapply All_forallb. - - assert (Alli (fun i => declared_inductive Σ {| inductive_mind := mind; inductive_ind := i |} mdecl) + + assert (Alli (fun i => declared_inductive Σ {| inductive_mind := mind; inductive_ind := i |} mdecl) 0 (ind_bodies mdecl)). { eapply forall_nth_error_Alli. intros. split; auto. } @@ -122,7 +122,7 @@ Proof. now move/andP: X. - pose proof (onConstructors oib). red in X. eapply All_forallb. eapply All2_All_left; eauto. - intros cdecl cs X0; + intros cdecl cs X0; move/andP: (on_ctype X0) => []. simpl. unfold closed_constructor_body. intros Hty _. @@ -141,7 +141,7 @@ Proof. specialize (X eq). clear eq. destruct (ind_ctors x) as [|cdecl []] eqn:hcdecl; try contradiction. apply on_projs in X. - assert (Alli (fun i pdecl => declared_projection Σ + assert (Alli (fun i pdecl => declared_projection Σ (mkProjection {| inductive_mind := mind; inductive_ind := n |} mdecl.(ind_npars) i) mdecl x cdecl pdecl) 0 (ind_projs x)). { eapply forall_nth_error_Alli. @@ -162,7 +162,7 @@ Proof. rewrite -> ?andb_and in *; try solve [intuition auto]. - induction X0; auto; rewrite closedn_ctx_cons /= IHX0 /= //. - now move/andP: Hs => [] /=. + now move/andP: Hs => [] /=. - pose proof (nth_error_Some_length H). elim (Nat.ltb_spec n #|Γ|); intuition auto. all: try lia. clear H1. @@ -177,7 +177,7 @@ Proof. now move/andP: ca => [_ cty]. now rewrite /test_decl /= in ca. simpl. - rewrite -Nat.add_1_r. + rewrite -Nat.add_1_r. rewrite -(simpl_lift _ (S n) 0 1 0); try lia. apply closedn_lift. apply IHΓ; auto. rewrite closedn_ctx_cons in H0. @@ -230,7 +230,7 @@ Proof. eapply declared_minductive_closed_ind in X0; tea. 2:exact isdecl. pose proof (closed_ind_closed_cstrs X0 isdecl). eapply All2i_All_mix_left in X5; tea. clear X6. - intuition auto. + intuition auto. + unfold test_predicate_k. simpl. rtoProp; intuition eauto. rewrite (closedn_ctx_alpha X1). eapply closed_ind_predicate_context in X0; tea. @@ -246,7 +246,7 @@ Proof. rewrite (wf_predicate_length_pars H1). now rewrite (declared_minductive_ind_npars isdecl). * rewrite (All2_length a1). - len in H8. + len in H8. (*unfold case_branch_context_gen in H8. simpl in H8. rewrite case_branch_type_fst in H8. *) rewrite case_branch_context_length_args in H8 => //. @@ -292,7 +292,7 @@ Proof. now rewrite andb_true_r in cl. Qed. -Lemma declared_minductive_closed {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {mdecl mind} : +Lemma declared_minductive_closed {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {mdecl mind} : declared_minductive Σ mind mdecl -> closed_inductive_decl mdecl. Proof. @@ -300,7 +300,7 @@ Proof. now apply (env_prop_sigma typecheck_closed). Qed. -Lemma declared_inductive_closed {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {mdecl mind idecl} : +Lemma declared_inductive_closed {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {mdecl mind idecl} : declared_inductive Σ mind mdecl idecl -> closed_inductive_body mdecl idecl. Proof. @@ -311,7 +311,7 @@ Proof. now simpl in cli. Qed. -Lemma declared_projection_closed {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ}{mdecl idecl p cdecl pdecl} : +Lemma declared_projection_closed {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ}{mdecl idecl p cdecl pdecl} : declared_projection Σ p mdecl idecl cdecl pdecl -> closedn (S (ind_npars mdecl)) pdecl.(proj_type). Proof. @@ -319,7 +319,7 @@ Proof. eapply (env_prop_sigma typecheck_closed); eauto. Qed. -Lemma declared_inductive_closed_pars_indices {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {mdecl mind idecl} : +Lemma declared_inductive_closed_pars_indices {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {mdecl mind idecl} : declared_inductive Σ mind mdecl idecl -> closed_ctx (ind_params mdecl ,,, ind_indices idecl). Proof. @@ -332,7 +332,7 @@ Proof. now rewrite closedn_ctx_app clpars indpars. Qed. -Lemma declared_constructor_closed {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {mdecl idecl c cdecl} : +Lemma declared_constructor_closed {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} {mdecl idecl c cdecl} : declared_constructor Σ c mdecl idecl cdecl -> closed_constructor_body mdecl cdecl. Proof. @@ -354,14 +354,14 @@ Qed. Implicit Types (cf : checker_flags) (Σ : global_env_ext). -Lemma subject_closed {cf} {Σ} {wfΣ : wf Σ.1} {Γ t T} : +Lemma subject_closed {cf} {Σ} {wfΣ : wf Σ.1} {Γ t T} : Σ ;;; Γ |- t : T -> closedn #|Γ| t. Proof. now move/(env_prop_typing typecheck_closed) => /andP [ct _]. Qed. -Lemma type_closed {cf} {Σ} {wfΣ : wf Σ.1} {Γ t T} : +Lemma type_closed {cf} {Σ} {wfΣ : wf Σ.1} {Γ t T} : Σ ;;; Γ |- t : T -> closedn #|Γ| T. Proof. @@ -406,7 +406,7 @@ Qed. Hint Rewrite is_open_term_closed is_closed_ctx_closed : fvs. #[global] Hint Extern 4 => progress autorewrite with fvs : fvs. -Lemma subject_is_open_term {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} {Γ t T} : +Lemma subject_is_open_term {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} {Γ t T} : Σ ;;; Γ |- t : T -> is_open_term Γ t. Proof. @@ -414,7 +414,7 @@ Proof. now rewrite is_open_term_closed. Qed. -Lemma type_is_open_term {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} {Γ t T} : +Lemma type_is_open_term {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ.1} {Γ t T} : Σ ;;; Γ |- t : T -> is_open_term Γ T. Proof. @@ -464,7 +464,7 @@ Qed. | [ H : _ ;;; Γ |- _ : _ |- _ ] => exact (typing_closed_context H) end : fvs. -Lemma ctx_inst_closed {cf:checker_flags} (Σ : global_env_ext) Γ i Δ : +Lemma ctx_inst_closed {cf:checker_flags} (Σ : global_env_ext) Γ i Δ : wf Σ.1 -> ctx_inst typing Σ Γ i Δ -> All (closedn #|Γ|) i. Proof. intros wfΣ; induction 1; auto; constructor; auto; fvs. @@ -537,7 +537,7 @@ Proof. eapply Alli_nth_error in h. 2: eassumption. simpl in h. destruct h as [? [? h] ? ? ?]. eapply typecheck_closed in h as [? e]. 2: auto. - now move: e => [_ /andP []]. + now move: e => [_ /andP []]. Qed. @@ -654,7 +654,7 @@ Proof. now move/andP: h => [/andP [hargs hindices]] hty. Qed. -Lemma closed_cstr_branch_context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind i mdecl idecl cdecl} : +Lemma closed_cstr_branch_context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind i mdecl idecl cdecl} : declared_constructor Σ (ind, i) mdecl idecl cdecl -> closedn_ctx (context_assumptions mdecl.(ind_params)) (cstr_branch_context ind mdecl cdecl). Proof. @@ -664,7 +664,7 @@ Proof. eapply declared_constructor_closed; tea. Qed. -Lemma closed_cstr_branch_context_npars {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind i mdecl idecl cdecl} : +Lemma closed_cstr_branch_context_npars {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind i mdecl idecl cdecl} : declared_constructor Σ (ind, i) mdecl idecl cdecl -> closedn_ctx (ind_npars mdecl) (cstr_branch_context ind mdecl cdecl). Proof. @@ -673,7 +673,7 @@ Proof. now apply (closed_cstr_branch_context declc). Qed. -Lemma declared_projection_closed_type {cf:checker_flags} +Lemma declared_projection_closed_type {cf:checker_flags} {Σ mdecl idecl p cdecl pdecl} {wfΣ : wf Σ} : declared_projection Σ p mdecl idecl cdecl pdecl -> closedn (S (ind_npars mdecl)) pdecl.(proj_type). @@ -685,7 +685,7 @@ Qed. #[global] Hint Unfold inst_case_branch_context : len. -(** This shows preservation by reduction of closed/noccur_between predicates +(** This shows preservation by reduction of closed/noccur_between predicates necessary to prove exchange and strengthening lemmas. *) Lemma red1_on_free_vars {cf:checker_flags} {P : nat -> bool} {Σ Γ u v} {wfΣ : wf Σ} : red1 Σ Γ u v -> @@ -726,7 +726,7 @@ Proof. len. rewrite skipn_length; try lia; rewrite H0. replace (ci_npar ci + context_assumptions (bcontext br) - ci_npar ci) - with (context_assumptions (bcontext br)) by lia. + with (context_assumptions (bcontext br)) by lia. rewrite /expand_lets /expand_lets_k /=. eapply forallb_nth_error in hbrs. erewrite H in hbrs; simpl in hbrs. @@ -735,14 +735,14 @@ Proof. * relativize (context_assumptions _). + unshelve eapply foron_free_vars_extended_subst. eauto. eapply on_free_vars_ctx_inst_case_context; tea => //. - + unfold inst_case_branch_context. now len. + + unfold inst_case_branch_context. now len. * rewrite extended_subst_length. rewrite shiftnP_add. eapply on_free_vars_lift_impl in hbody. unfold inst_case_branch_context. len. now rewrite Nat.add_comm. - rewrite !on_free_vars_mkApps in hav |- *. rtoProp. - eapply on_free_vars_unfold_fix in H; eauto. + eapply on_free_vars_unfold_fix in H; eauto. - move: h4; rewrite !on_free_vars_mkApps. move=> /andP [] hcofix ->. eapply on_free_vars_unfold_cofix in hcofix; eauto. @@ -814,7 +814,7 @@ Qed. Lemma term_closedn_list_ind : - forall (P : nat -> term -> Type), + forall (P : nat -> term -> Type), (forall k (n : nat), n < k -> P k (tRel n)) -> (forall k (i : ident), P k (tVar i)) -> (forall k (n : nat) (l : list term), All (P k) l -> P k (tEvar n l)) -> @@ -828,7 +828,7 @@ Lemma term_closedn_list_ind : (forall k (i : inductive) (u : list Level.t), P k (tInd i u)) -> (forall k (i : inductive) (n : nat) (u : list Level.t), P k (tConstruct i n u)) -> (forall k (ci : case_info) (p : predicate term), - tCasePredProp_k P k p -> + tCasePredProp_k P k p -> forall t0 : term, P k t0 -> forall l : list (branch term), tCaseBrsProp_k P p k l -> P k (tCase ci p t0 l)) -> (forall k (s : projection) (t : term), P k t -> P k (tProj s t)) -> @@ -843,13 +843,13 @@ Proof. intros k t. destruct t; intros clt; match goal with H : _ |- _ => apply H - end; auto; simpl in clt; - try move/andP: clt => [cl1 cl2]; + end; auto; simpl in clt; + try move/andP: clt => [cl1 cl2]; try move/andP: cl1 => [cl1 cl1']; try solve[apply auxt; auto]; simpl in *. - - - now apply Nat.ltb_lt in clt. + + - now apply Nat.ltb_lt in clt. - revert l clt. fix auxl' 1. destruct l; constructor; [|apply auxl']. @@ -878,7 +878,7 @@ Proof. rewrite Nat.sub_0_r //. split; auto. exact tt. eapply Alli_shift, Alli_impl; eauto. simpl. intros n x. now replace (Nat.pred #|l| - n + #|pparams p|) with (#|l| - S n + #|pparams p|) by lia. - * apply auxt => //. + * apply auxt => //. - unfold tCaseBrsProp_k. revert brs cl2. clear cl1 cl1'. rewrite /test_branch_k. @@ -907,7 +907,7 @@ Proof. revert clt. generalize (#|mfix|). revert mfix. - fix auxm 1. + fix auxm 1. destruct mfix; intros; constructor. simpl in clt. move/andP: clt => [clt cll]. simpl in clt. move/andP: clt. intuition auto. @@ -918,7 +918,7 @@ Proof. revert clt. generalize (#|mfix|). revert mfix. - fix auxm 1. + fix auxm 1. destruct mfix; intros; constructor. simpl in clt. move/andP: clt => [clt cll]. simpl in clt. move/andP: clt. intuition auto. @@ -926,7 +926,7 @@ Proof. Defined. Lemma term_noccur_between_list_ind : - forall (P : nat -> nat -> term -> Type), + forall (P : nat -> nat -> term -> Type), (forall k n (i : nat), i < k \/ k + n <= i -> P k n (tRel i)) -> (forall k n (i : ident), P k n (tVar i)) -> (forall k n (id : nat) (l : list term), All (P k n) l -> P k n (tEvar id l)) -> @@ -940,7 +940,7 @@ Lemma term_noccur_between_list_ind : (forall k n (i : inductive) (u : list Level.t), P k n (tInd i u)) -> (forall k n (i : inductive) (c : nat) (u : list Level.t), P k n (tConstruct i c u)) -> (forall k n (ci : case_info) (p : predicate term), - tCasePredProp_k (fun k' => P k' n) k p -> forall t0 : term, P k n t0 -> + tCasePredProp_k (fun k' => P k' n) k p -> forall t0 : term, P k n t0 -> forall l : list (branch term), tCaseBrsProp_k (fun k' => P k' n) p k l -> P k n (tCase ci p t0 l)) -> (forall k n (s : projection) (t : term), P k n t -> P k n (tProj s t)) -> @@ -955,22 +955,22 @@ Proof. intros k n t. destruct t; intros clt; match goal with H : _ |- _ => apply H - end; auto; simpl in clt; - try move/andP: clt => [cl1 cl2]; + end; auto; simpl in clt; + try move/andP: clt => [cl1 cl2]; try move/andP: cl1 => [cl1 cl1']; try solve[apply auxt; auto]; simpl in *. - - move/orP: clt => [cl|cl]. + - move/orP: clt => [cl|cl]. now apply Nat.ltb_lt in cl; eauto. - now apply Nat.leb_le in cl; eauto. - + now apply Nat.leb_le in cl; eauto. + - revert l clt. fix auxl' 1. destruct l; constructor; [|apply auxl']. apply auxt. simpl in clt. now move/andP: clt => [clt cll]. now move/andP: clt => [clt cll]. - + - move/andP: cl1 => /= []/andP[] clpars clctx clret. split. * revert clpars. generalize (pparams p). @@ -1013,7 +1013,7 @@ Proof. revert clt. generalize (#|mfix|). revert mfix. - fix auxm 1. + fix auxm 1. destruct mfix; intros; constructor. simpl in clt. move/andP: clt => [clt cll]. simpl in clt. move/andP: clt. intuition auto. @@ -1024,7 +1024,7 @@ Proof. revert clt. generalize (#|mfix|). revert mfix. - fix auxm 1. + fix auxm 1. destruct mfix; intros; constructor. simpl in clt. move/andP: clt => [clt cll]. simpl in clt. move/andP: clt. intuition auto. diff --git a/pcuic/theories/Typing/PCUICContextConversionTyp.v b/pcuic/theories/Typing/PCUICContextConversionTyp.v index 53df27200..95a7639c7 100644 --- a/pcuic/theories/Typing/PCUICContextConversionTyp.v +++ b/pcuic/theories/Typing/PCUICContextConversionTyp.v @@ -18,10 +18,10 @@ Implicit Types (cf : checker_flags) (Σ : global_env_ext). Lemma lift0_open {cf:checker_flags} {Γ : closed_context} {Γ'' : open_context Γ} {M : open_term Γ} {n} : n = #|Γ''| -> is_open_term (Γ ,,, Γ'') (lift0 n M). -Proof. +Proof. intro e. rewrite on_free_vars_lift0; eauto. rewrite app_length. rewrite <- shiftnP_add. subst. rewrite addnP_shiftnP; intuition. -Defined. +Defined. Lemma weakening_cumulSpec0 {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : closed_context} {Γ'' : open_context Γ} {M N : open_term Γ} n : @@ -29,17 +29,17 @@ Lemma weakening_cumulSpec0 {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ ;;; Γ |- M <=s N -> Σ ;;; Γ ,,, Γ'' |- lift0 n M <=s lift0 n N. Proof. - intros e H. - eapply (@cumulAlgo_cumulSpec _ _ Cumul). + intros e H. + eapply (@cumulAlgo_cumulSpec _ _ Cumul). eapply into_ws_cumul_pb; try apply lift0_open; eauto. - - cbn. eapply weakening_cumul0; eauto. apply cumulSpec_cumulAlgo in H; eauto. exact (ws_cumul_pb_forget H). - - cbn. rewrite on_free_vars_ctx_app; solve_all; intuition. -Defined. + - cbn. eapply weakening_cumul0; eauto. apply cumulSpec_cumulAlgo in H; eauto. exact (ws_cumul_pb_forget H). + - cbn. rewrite on_free_vars_ctx_app; solve_all; intuition. +Defined. -Lemma split_closed_context {Γ : context} (n : nat) : +Lemma split_closed_context {Γ : context} (n : nat) : is_closed_context Γ -> n <= #|Γ| -> - ∑ (Δ : closed_context) (Δ' : open_context Δ), + ∑ (Δ : closed_context) (Δ' : open_context Δ), [× Δ = skipn n Γ :> context, Δ' = firstn n Γ :> context, Γ = Δ ,,, Δ' & n = #|Δ'|]. Proof. @@ -52,7 +52,7 @@ Proof. Qed. Lemma nth_error_closed_context {Γ n d} : - is_closed_context Γ -> + is_closed_context Γ -> nth_error Γ n = Some d -> ws_decl (skipn (S n) Γ) d. Proof. @@ -66,7 +66,7 @@ Proof. apply Nat.ltb_lt. lia. Qed. -Lemma on_free_vars_decl_lift (p : nat -> bool) n k t : +Lemma on_free_vars_decl_lift (p : nat -> bool) n k t : on_free_vars_decl (strengthenP k n p) (lift_decl n k t) = on_free_vars_decl p t. Proof. rewrite /on_free_vars_decl /test_decl /=. @@ -74,7 +74,7 @@ Proof. all:now rewrite on_free_vars_lift. Qed. -Lemma on_free_vars_decl_lift_impl (p : nat -> bool) n k d : +Lemma on_free_vars_decl_lift_impl (p : nat -> bool) n k d : on_free_vars_decl (shiftnP k p) d -> on_free_vars_decl (shiftnP (n + k) p) (lift_decl n k d). Proof. @@ -86,8 +86,8 @@ Proof. move/(on_free_vars_lift_impl _ n) -> => //. Qed. -Lemma nth_error_Some_add {A} (l : list A) (n : nat) (x : A) : - (nth_error l n = Some x) <~> +Lemma nth_error_Some_add {A} (l : list A) (n : nat) (x : A) : + (nth_error l n = Some x) <~> (n < #|l| × nth_error l n = Some x). Proof. split. intros hnth; split => //. @@ -96,7 +96,7 @@ Proof. Qed. Lemma nth_error_closed_context_lift {Γ n d} : - is_closed_context Γ -> + is_closed_context Γ -> nth_error Γ n = Some d -> ws_decl Γ (lift_decl (S n) 0 d). Proof. @@ -111,7 +111,7 @@ Lemma wt_cum_ws_cumul_pb {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} Σ ;;; Γ |- t : A -> Σ ;;; Γ |- B : tSort s -> Σ ;;; Γ |- A <= B -> - Σ ;;; Γ ⊢ A ≤ B. + Σ ;;; Γ ⊢ A ≤ B. Proof. move=> a; move: a (typing_wf_local a). move/PCUICClosedTyp.type_closed/(@closedn_on_free_vars xpred0) => clA. @@ -124,20 +124,20 @@ Lemma wt_cum_ws_cumul_ctx_pb {cf:checker_flags} {Σ:global_env_ext} {wfΣ : wf wf_local Σ Γ -> wf_local Σ Δ -> cumul_pb_context cumulAlgo_gen pb Σ Γ Δ -> - Σ ⊢ Γ ≤[pb] Δ. + Σ ⊢ Γ ≤[pb] Δ. Proof. move/wf_local_closed_context => wfΓ. move/wf_local_closed_context => wfΔ. now eapply into_ws_cumul_ctx_pb. Qed. -Lemma All2_conv_over_refl {cf:checker_flags} {Σ : global_env_ext} {Γ Γ' Δ} : +Lemma All2_conv_over_refl {cf:checker_flags} {Σ : global_env_ext} {Γ Γ' Δ} : All2_fold (All_over (conv_decls cumulAlgo_gen Σ) Γ Γ') Δ Δ. Proof. eapply All2_fold_refl. intros ? ?; reflexivity. Qed. -Lemma All2_cumul_over_refl {cf:checker_flags} {Σ : global_env_ext} {Γ Γ' Δ} : +Lemma All2_cumul_over_refl {cf:checker_flags} {Σ : global_env_ext} {Γ Γ' Δ} : All2_fold (All_over (cumul_decls cumulAlgo_gen Σ) Γ Γ') Δ Δ. Proof. eapply All2_fold_refl. intros ? ?; reflexivity. @@ -154,12 +154,12 @@ Proof. + eapply (@cumulAlgo_cumulSpec _ _ Conv); eauto. + eapply (@cumulAlgo_cumulSpec _ _ Cumul); eauto. Defined. - + Lemma context_cumulativity_prop {cf:checker_flags} : env_prop (fun Σ Γ t T => forall Γ', cumul_context cumulAlgo_gen Σ Γ' Γ -> wf_local Σ Γ' -> Σ ;;; Γ' |- t : T) - (fun Σ Γ => + (fun Σ Γ => All_local_env (lift_typing (fun Σ (Γ : context) (t T : term) => forall Γ' : context, cumul_context cumulAlgo_gen Σ Γ' Γ -> wf_local Σ Γ' -> Σ;;; Γ' |- t : T) Σ) Γ). @@ -198,7 +198,7 @@ Proof. eapply (@closedn_on_free_vars xpred0) in Hty. eapply (weakening_cumulSpec0 (Γ := Δ) (Γ'' := Δ') (M := exist t H) (N := exist ty Hty)); cbn. lia. unshelve eapply (@cumulAlgo_cumulSpec _ _ Cumul). apply into_ws_cumul_pb; eauto. - intuition. + intuition. + cbn in X. destruct X as [s ondecl]. specialize (ondecl _ Hrel). depelim Hconv. @@ -228,7 +228,7 @@ Proof. eapply (@closedn_on_free_vars xpred0) in ondecl. eapply (weakening_cumulSpec0 (Γ := Δ) (Γ'' := Δ') (M := exist t H) (N := exist ty ondecl)); cbn. lia. unshelve eapply (@cumulAlgo_cumulSpec _ _ Cumul). apply into_ws_cumul_pb; eauto. - intuition. + intuition. - constructor; pcuic. eapply forall_Γ'0. repeat (constructor; pcuic). constructor; auto. red. eexists; eapply forall_Γ'; auto. @@ -236,7 +236,7 @@ Proof. eapply forall_Γ'0; repeat (constructor; pcuic). - econstructor; pcuic. eapply forall_Γ'1; repeat (constructor; pcuic). - - econstructor; eauto. 2,3: constructor; eauto. + - econstructor; eauto. 2,3: constructor; eauto. * eapply IHp0. rewrite /predctx. eapply All2_fold_app => //. eapply All2_fold_refl. intros ? ?; reflexivity. @@ -255,10 +255,10 @@ Proof. eapply All2_fold_app => //. apply All2_cumul_over_refl. eapply context_cumulativity_wf_app; tea. - econstructor. - all:pcuic. + all:pcuic. * eapply fix_guard_context_cumulativity; eauto. - eapply cumul_context_Algo_Spec; eauto. eapply into_ws_cumul_ctx_pb; eauto. - + apply wf_local_closed_context; eauto. + eapply cumul_context_Algo_Spec; eauto. eapply into_ws_cumul_ctx_pb; eauto. + + apply wf_local_closed_context; eauto. + apply wf_local_closed_context; eauto. * eapply (All_impl X0). intros d Ht. @@ -274,8 +274,8 @@ Proof. - econstructor. all:pcuic. * eapply cofix_guard_context_cumulativity; eauto. - eapply cumul_context_Algo_Spec; eauto. eapply into_ws_cumul_ctx_pb; eauto. - + apply wf_local_closed_context; eauto. + eapply cumul_context_Algo_Spec; eauto. eapply into_ws_cumul_ctx_pb; eauto. + + apply wf_local_closed_context; eauto. + apply wf_local_closed_context; eauto. * eapply (All_impl X0). intros d Ht. @@ -288,30 +288,30 @@ Proof. apply (All_impl X0); simpl. intros d' Ht. apply infer_typing_sort_impl with id Ht; now intros [_ IH']. - + - econstructor; eauto. pose proof (wf_local_closed_context wfΓ). - pose proof (type_closed (forall_Γ' _ X5 X6)). eapply (@closedn_on_free_vars xpred0) in H0. - pose proof (subject_closed (forall_Γ'0 _ X5 X6)). eapply (@closedn_on_free_vars xpred0) in H1. - pose proof (type_closed typet). eapply (@closedn_on_free_vars xpred0) in H2. - pose proof (subject_closed typeB). eapply (@closedn_on_free_vars xpred0) in H3. + pose proof (type_closed (forall_Γ' _ X5 X6)). eapply (@closedn_on_free_vars xpred0) in H0. + pose proof (subject_closed (forall_Γ'0 _ X5 X6)). eapply (@closedn_on_free_vars xpred0) in H1. + pose proof (type_closed typet). eapply (@closedn_on_free_vars xpred0) in H2. + pose proof (subject_closed typeB). eapply (@closedn_on_free_vars xpred0) in H3. unshelve eapply (@cumulAlgo_cumulSpec _ _ Cumul); eauto. apply into_ws_cumul_pb; eauto. - * unshelve eapply (cumulSpec_cumulAlgo _ _ (exist Γ _) (exist A _) (exist B _)) in X4; eauto. + * unshelve eapply (cumulSpec_cumulAlgo _ _ (exist Γ _) (exist A _) (exist B _)) in X4; eauto. apply ws_cumul_pb_forget in X4. eapply wt_cum_ws_cumul_pb in X4; tea. apply (wt_cum_ws_cumul_ctx_pb Cumul) in X5; tea. eapply (ws_cumul_pb_ws_cumul_ctx X5) in X4. now eapply ws_cumul_pb_forget in X4. - * eapply wf_local_closed_context; eauto. -Qed. + * eapply wf_local_closed_context; eauto. +Qed. -Lemma closed_context_cumul_cumul {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} : +Lemma closed_context_cumul_cumul {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} : Σ ⊢ Γ ≤ Γ' -> cumul_context cumulAlgo_gen Σ Γ Γ'. Proof. now move/ws_cumul_ctx_pb_forget. Qed. #[global] Hint Resolve closed_context_cumul_cumul : pcuic. -Lemma closed_context_conv_conv {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} : +Lemma closed_context_conv_conv {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} : Σ ⊢ Γ = Γ' -> conv_context cumulAlgo_gen Σ Γ Γ'. Proof. now move/ws_cumul_ctx_pb_forget. @@ -344,7 +344,7 @@ Qed. #[global] Hint Resolve wf_local_closed_context : fvs. Lemma wf_conv_context_closed {cf:checker_flags} {Σ} {wfΣ : wf Σ.1} {Γ Γ'} : - conv_context cumulAlgo_gen Σ Γ Γ' -> + conv_context cumulAlgo_gen Σ Γ Γ' -> wf_local Σ Γ -> wf_local Σ Γ' -> Σ ⊢ Γ = Γ'. @@ -354,7 +354,7 @@ Proof. Qed. Lemma wf_cumul_context_closed {cf:checker_flags} {Σ} {wfΣ : wf Σ.1} {Γ Γ'} : - cumul_context cumulAlgo_gen Σ Γ Γ' -> + cumul_context cumulAlgo_gen Σ Γ Γ' -> wf_local Σ Γ -> wf_local Σ Γ' -> Σ ⊢ Γ ≤ Γ'. diff --git a/pcuic/theories/Typing/PCUICInstTyp.v b/pcuic/theories/Typing/PCUICInstTyp.v index 3ea034fc6..0dc52e1ac 100644 --- a/pcuic/theories/Typing/PCUICInstTyp.v +++ b/pcuic/theories/Typing/PCUICInstTyp.v @@ -3,7 +3,7 @@ From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICCases PCUICInduction PCUICLiftSubst PCUICUnivSubst - PCUICTyping PCUICReduction PCUICCumulativity + PCUICTyping PCUICReduction PCUICCumulativity PCUICEquality PCUICGlobalEnv PCUICClosed PCUICClosedConv PCUICClosedTyp PCUICEquality PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICSigmaCalculus PCUICRenameDef PCUICRenameConv PCUICWeakeningConv PCUICWeakeningTyp PCUICInstDef PCUICInstConv PCUICGuardCondition PCUICUnivSubstitutionConv PCUICOnFreeVars PCUICOnFreeVarsConv PCUICClosedTyp PCUICClosedTyp. @@ -21,46 +21,46 @@ Implicit Types cf : checker_flags. Open Scope sigma_scope. Definition well_subst_usubst {cf} (Σ:global_env_ext) (wfΣ : wf Σ) Γ σ Δ : - is_closed_context Δ -> + is_closed_context Δ -> Σ ;;; Δ ⊢ σ : Γ -> usubst Γ σ Δ. Proof. - intuition. -Defined. + intuition. +Defined. Definition well_subst_closed_subst {cf} (Σ:global_env_ext) (wfΣ : wf Σ) Γ σ Δ : - is_closed_context Δ -> + is_closed_context Δ -> Σ ;;; Δ ⊢ σ : Γ -> closed_subst Γ σ Δ. Proof. - intros hΔ [typed_σ hσ]. repeat split; tea. - intros x decl hnth. specialize (typed_σ x decl hnth) as htype. - pose proof (typing_wf_local htype). pose (wf_local_closed_context X). + intros hΔ [typed_σ hσ]. repeat split; tea. + intros x decl hnth. specialize (typed_σ x decl hnth) as htype. + pose proof (typing_wf_local htype). pose (wf_local_closed_context X). apply closedn_on_free_vars. eapply subject_closed; eauto. -Defined. +Defined. Lemma inst_context_on_free_vars σ n l : -on_free_vars_ctx (closedP n xpredT) l -> +on_free_vars_ctx (closedP n xpredT) l -> inst_context (⇑^n σ) l = l. Proof. - intro Hclosed. - unfold on_free_vars_ctx in Hclosed. - unfold inst_context, fold_context_k. + intro Hclosed. + unfold on_free_vars_ctx in Hclosed. + unfold inst_context, fold_context_k. induction l; eauto. cbn in *. rewrite alli_app in Hclosed. toProp Hclosed. - destruct Hclosed as [H Hclosed]. + destruct Hclosed as [H Hclosed]. rewrite mapi_rec_app. rewrite List.distr_rev. rewrite IHl; eauto. cbn in *. f_equal. toProp Hclosed. replace (#|List.rev l| + 0) with (#|List.rev l|) in * by lia. destruct Hclosed as [Hclosed _]. destruct a; unfold map_decl; cbn. - unfold on_free_vars_decl in Hclosed. + unfold on_free_vars_decl in Hclosed. unfold test_decl in Hclosed. toProp Hclosed. cbn in Hclosed. destruct Hclosed as [Hbody Htype]. f_equal. - - destruct decl_body; eauto; cbn in *. + - destruct decl_body; eauto; cbn in *. f_equal. rewrite closedP_shiftnP in Hbody. rewrite <- Upn_Upn. rewrite shiftnP_add in Hbody. @@ -70,31 +70,31 @@ Proof. apply inst_on_free_vars; eauto. Defined. -Lemma inst_case_predicate_context_inst σ p : +Lemma inst_case_predicate_context_inst σ p : on_free_vars_ctx (closedP #|pparams p| xpredT) (pcontext p) -> - PCUICCases.inst_case_predicate_context (inst_predicate σ p) = + PCUICCases.inst_case_predicate_context (inst_predicate σ p) = inst_context σ (PCUICCases.inst_case_predicate_context p). -Proof. +Proof. intro Hclosed. unfold PCUICCases.inst_case_predicate_context. unfold pparams at 1. cbn. - replace (pcontext p) with + replace (pcontext p) with (inst_context (⇑^#|pparams p| σ) (pcontext p)) at 1. - rewrite <- inst_inst_case_context; eauto. - apply inst_context_on_free_vars; eauto. -Defined. +Defined. -Lemma inst_case_branch_context_inst σ p x : -on_free_vars_ctx (closedP #|pparams p| xpredT) (bcontext x) -> -inst_case_branch_context (inst_predicate σ p) +Lemma inst_case_branch_context_inst σ p x : +on_free_vars_ctx (closedP #|pparams p| xpredT) (bcontext x) -> +inst_case_branch_context (inst_predicate σ p) (inst_branch σ x) = inst_context σ (inst_case_branch_context p x). Proof. - intro Hclosed. unfold inst_case_branch_context. cbn. - replace (bcontext x) with + intro Hclosed. unfold inst_case_branch_context. cbn. + replace (bcontext x) with (inst_context (⇑^#|pparams p| σ) (bcontext x)) at 1. - rewrite <- inst_inst_case_context; eauto. - apply inst_context_on_free_vars; eauto. -Defined. +Defined. Lemma inst_cumulSpec {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {pb Γ Δ σ A B} : closed_subst Γ σ Δ -> @@ -104,8 +104,8 @@ Lemma inst_cumulSpec {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} { Σ ;;; Γ ⊢ A ≤s[pb] B -> Σ ;;; Δ ⊢ A.[σ] ≤s[pb] B.[σ]. Proof. - intros hσ HΓ HfreeA HfreeB e. - revert pb Γ A B e Δ σ hσ HΓ HfreeA HfreeB e. + intros hσ HΓ HfreeA HfreeB e. + revert pb Γ A B e Δ σ hσ HΓ HfreeA HfreeB e. apply: (cumulSpec0_ind_all Σ); intros. all: repeat inv_on_free_vars. - rewrite subst10_inst. sigma. solve [econstructor]. @@ -124,7 +124,7 @@ Proof. rewrite inst_iota_red //. * rewrite skipn_length; lia. * change (bcontext br) with (bcontext (inst_branch σ br)). - rewrite closedn_ctx_on_free_vars. + rewrite closedn_ctx_on_free_vars. eapply nth_error_forallb in p4; tea. simpl in p4. move/andP: p4 => [] clbctx clbod. now rewrite test_context_k_closed_on_free_vars_ctx in clbctx. @@ -149,197 +149,197 @@ Proof. - simpl. rewrite inst_mkApps. simpl. eapply cumul_proj; rewrite nth_error_map. rewrite H. reflexivity. - pose proof hσ.1. - eapply cumul_Trans; try eapply X0; try eapply X2; eauto. + eapply cumul_Trans; try eapply X0; try eapply X2; eauto. eapply inst_is_open_term; eauto. - - eapply cumul_Sym; try eapply X0; eauto. + - eapply cumul_Sym; try eapply X0; eauto. - eapply cumul_Refl; eauto. - - cbn. eapply cumul_Evar. cbn in *. + - cbn. eapply cumul_Evar. cbn in *. eapply All2_All_mix_left in X; tea. eapply All2_All_mix_right in X; tea. eapply All2_map. eapply All2_impl. 1:tea. cbn; intros. eapply X0.1.2; intuition. - - eapply cumul_App; try apply X0; try apply X2; eauto. + - eapply cumul_App; try apply X0; try apply X2; eauto. - pose proof hσ.1. cbn; eapply cumul_Lambda; try apply X0; try apply X2; eauto; - try rewrite shiftnP_S; eauto. + try rewrite shiftnP_S; eauto. * eapply closed_subst_up_vass; eauto. eapply inst_is_open_term; eauto. * rewrite on_free_vars_ctx_snoc. apply andb_and; split; eauto. - eapply cumul_Prod; try apply X0; try apply X2; eauto; try rewrite shiftnP_S; eauto. - * eapply closed_subst_up_vass; eauto. eapply inst_is_open_term; eauto. + * eapply closed_subst_up_vass; eauto. eapply inst_is_open_term; eauto. * rewrite on_free_vars_ctx_snoc. apply andb_and; split; eauto. - - eapply cumul_LetIn; try apply X0; try apply X2; eauto; try apply X4; + - eapply cumul_LetIn; try apply X0; try apply X2; eauto; try apply X4; try rewrite shiftnP_S; eauto. * eapply closed_subst_up_vdef; eauto; eapply inst_is_open_term; eauto. * rewrite on_free_vars_ctx_snoc_def; eauto. - rename p0 into Hp'; rename p1 into Hreturn'; rename p2 into Hcontext'; rename p3 into Hc'; rename p4 into Hbrs'. rename p5 into Hp; rename p6 into Hreturn; rename p7 into Hcontext; rename p8 into Hc; rename p9 into Hbrs. - eapply cumul_Case; fold inst. + eapply cumul_Case; fold inst. * unfold cumul_predicate. unfold cumul_predicate in X. destruct X as [Xparam [Xuniv [Xcontext [Xeq Xreturn]]]]. - repeat split; eauto. - + eapply All2_map. apply forallb_All in Hp, Hp'. eapply (All2_All_mix_left Hp) in Xparam. + repeat split; eauto. + + eapply All2_map. apply forallb_All in Hp, Hp'. eapply (All2_All_mix_left Hp) in Xparam. eapply (All2_All_mix_right Hp') in Xparam. eapply All2_impl. 1: tea. cbn; intros. destruct X as [[X [X''' X']] X'']. apply X'; eauto. + unfold preturn. cbn. rewrite (All2_fold_length Xcontext). eapply Xreturn; eauto. ++ rewrite <- (All2_fold_length Xcontext). rewrite <- inst_case_predicate_context_length. - rewrite inst_case_predicate_context_inst; eauto. + rewrite inst_case_predicate_context_inst; eauto. eapply closed_subst_ext. 2: symmetry; apply up_Upn. - eapply closed_subst_app; eauto. rewrite inst_inst_case_context; eauto. + eapply closed_subst_app; eauto. rewrite inst_inst_case_context; eauto. rewrite on_free_vars_ctx_inst_case_context_nil; eauto. +++ rewrite forallb_map. eapply forallb_impl. 2:tea. cbn; intros. - eapply inst_is_open_term; eauto. + eapply inst_is_open_term; eauto. +++ rewrite map_length. rewrite inst_context_on_free_vars ; eauto. - ++ unfold PCUICCases.inst_case_predicate_context. + ++ unfold PCUICCases.inst_case_predicate_context. apply on_free_vars_ctx_inst_case_context; eauto. ++ unfold PCUICCases.inst_case_predicate_context. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite inst_case_predicate_context_length. + rewrite <- shiftnP_add. + rewrite inst_case_predicate_context_length. eassumption. ++ unfold PCUICCases.inst_case_predicate_context. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite inst_case_predicate_context_length. + rewrite <- shiftnP_add. + rewrite inst_case_predicate_context_length. rewrite (All2_fold_length Xcontext). eassumption. - * apply X1; eauto. + * apply X1; eauto. * rename X2 into Hbrsbrs'. - apply forallb_All in Hbrs, Hbrs'. apply (All2_All_mix_left Hbrs) in Hbrsbrs'. clear Hbrs. + apply forallb_All in Hbrs, Hbrs'. apply (All2_All_mix_left Hbrs) in Hbrsbrs'. clear Hbrs. apply (All2_All_mix_right Hbrs') in Hbrsbrs'. clear Hbrs'. apply All2_map. eapply All2_impl. 1: tea. cbn; intros x y [[Hx Heqxy ] Hy]. destruct Heqxy as [[Hbcontext Hbody] Heqxy]. rewrite (All2_fold_length Hbcontext). - split; eauto. + split; eauto. apply andb_and in Hx. destruct Hx as [Hx Hbodyx]. apply andb_and in Hy. destruct Hy as [Hy Hbodyy]. - rewrite test_context_k_closed_on_free_vars_ctx in Hx. + rewrite test_context_k_closed_on_free_vars_ctx in Hx. apply Heqxy; eauto. - + rewrite <- (All2_fold_length Hbcontext). + + rewrite <- (All2_fold_length Hbcontext). rewrite <- (inst_case_branch_context_length p). - rewrite inst_case_branch_context_inst; eauto. + rewrite inst_case_branch_context_inst; eauto. eapply closed_subst_ext. 2: symmetry; apply up_Upn. - eapply closed_subst_app; eauto. + eapply closed_subst_app; eauto. rewrite inst_inst_case_context_wf; eauto. ++ rewrite test_context_k_closed_on_free_vars_ctx; tea. ++ rewrite on_free_vars_ctx_inst_case_context_nil; eauto. - +++ rewrite forallb_map. eapply forallb_impl. 2:tea. simpl; intros. + +++ rewrite forallb_map. eapply forallb_impl. 2:tea. simpl; intros. eapply inst_is_open_term; eauto. - +++ rewrite map_length. tea. - + unfold PCUICCases.inst_case_predicate_context. + +++ rewrite map_length. tea. + + unfold PCUICCases.inst_case_predicate_context. apply on_free_vars_ctx_inst_case_context; eauto. + unfold PCUICCases.inst_case_predicate_context. unfold is_open_term. rewrite app_length. rewrite <- shiftnP_add. - rewrite inst_case_branch_context_length. + rewrite inst_case_branch_context_length. eassumption. + unfold PCUICCases.inst_case_predicate_context. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite inst_case_branch_context_length. + rewrite <- shiftnP_add. + rewrite inst_case_branch_context_length. rewrite (All2_fold_length Hbcontext). eassumption. - eapply cumul_Proj; try apply X0; eauto. - - cbn. eapply cumul_Fix. cbn in HfreeA, HfreeB. - apply (All2_All_mix_left HfreeA) in X. clear HfreeA. + - cbn. eapply cumul_Fix. cbn in HfreeA, HfreeB. + apply (All2_All_mix_left HfreeA) in X. clear HfreeA. apply (All2_All_mix_right HfreeB) in X. clear HfreeB. apply All2_map. eapply All2_impl. 1: tea. cbn; intros. destruct X0 as [[Hx [[[_Htype [Htype Hbody_]] [Hbody Harg]] Hname]] Hy]. repeat split; eauto. - * eapply Htype; eauto. + * eapply Htype; eauto. + cbn in Hx; eapply andb_and in Hx. intuition. + cbn in Hy; eapply andb_and in Hy. intuition. - * rewrite <- (All2_length X). eapply Hbody; eauto. + * rewrite <- (All2_length X). eapply Hbody; eauto. + rewrite inst_fix_context_up. rewrite <- fix_context_length. eapply closed_subst_ext. 2: symmetry; apply up_Upn. apply closed_subst_app; eauto. rewrite <- inst_fix_context. apply on_free_vars_fix_context. - apply All_map. + apply All_map. eapply All2_All_left. 1: tea. cbn ; intros. destruct X0 as [[Hx0 _] _]. unfold test_def. unfold test_def in Hx0. apply andb_and in Hx0. destruct Hx0 as [Hx0type Hx0body]. - apply andb_and. cbn. split. + apply andb_and. cbn. split. ++ eapply inst_is_open_term; eauto. - ++ rewrite map_length. - rewrite <- fix_context_length. rewrite <- up_Upn. + ++ rewrite map_length. + rewrite <- fix_context_length. rewrite <- up_Upn. eapply usubst_on_free_vars_shift; eauto. rewrite fix_context_length; eauto. - + rewrite on_free_vars_ctx_app. + + rewrite on_free_vars_ctx_app. apply andb_and; split; eauto. apply on_free_vars_fix_context. eapply All2_All_left. 1: tea. cbn; intros. apply X0.1. - + unfold test_def in Hx. apply andb_and in Hx. - destruct Hx as [_ Hx]. + + unfold test_def in Hx. apply andb_and in Hx. + destruct Hx as [_ Hx]. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite fix_context_length. exact Hx. - + unfold test_def in Hy. apply andb_and in Hy. - destruct Hy as [_ Hy]. + rewrite <- shiftnP_add. + rewrite fix_context_length. exact Hx. + + unfold test_def in Hy. apply andb_and in Hy. + destruct Hy as [_ Hy]. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite fix_context_length. + rewrite <- shiftnP_add. + rewrite fix_context_length. rewrite (All2_length X). exact Hy. - cbn. rewrite (All2_length X). - eapply cumul_CoFix. cbn in HfreeA, HfreeB. - apply (All2_All_mix_left HfreeA) in X. clear HfreeA. + eapply cumul_CoFix. cbn in HfreeA, HfreeB. + apply (All2_All_mix_left HfreeA) in X. clear HfreeA. apply (All2_All_mix_right HfreeB) in X. clear HfreeB. apply All2_map. eapply All2_impl. 1: tea. cbn; intros. destruct X0 as [[Hx [[[_Htype [Htype Hbody_]] [Hbody Harg]] Hname]] Hy]. repeat split; eauto. - * eapply Htype; eauto. + * eapply Htype; eauto. + cbn in Hx; eapply andb_and in Hx. intuition. + cbn in Hy; eapply andb_and in Hy. intuition. - * rewrite <- (All2_length X). eapply Hbody; eauto. + * rewrite <- (All2_length X). eapply Hbody; eauto. + rewrite inst_fix_context_up. rewrite <- fix_context_length. eapply closed_subst_ext. 2: symmetry; apply up_Upn. apply closed_subst_app; eauto. rewrite <- inst_fix_context. apply on_free_vars_fix_context. - apply All_map. + apply All_map. eapply All2_All_left. 1: tea. cbn ; intros. destruct X0 as [[Hx0 _] _]. unfold test_def. unfold test_def in Hx0. apply andb_and in Hx0. destruct Hx0 as [Hx0type Hx0body]. - apply andb_and. cbn. split. + apply andb_and. cbn. split. ++ eapply inst_is_open_term; eauto. - ++ rewrite map_length. - rewrite <- fix_context_length. rewrite <- up_Upn. + ++ rewrite map_length. + rewrite <- fix_context_length. rewrite <- up_Upn. eapply usubst_on_free_vars_shift; eauto. rewrite fix_context_length; eauto. - + rewrite on_free_vars_ctx_app. + + rewrite on_free_vars_ctx_app. apply andb_and; split; eauto. apply on_free_vars_fix_context. eapply All2_All_left. 1: tea. cbn; intros. apply X0.1. - + unfold test_def in Hx. apply andb_and in Hx. - destruct Hx as [_ Hx]. + + unfold test_def in Hx. apply andb_and in Hx. + destruct Hx as [_ Hx]. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite fix_context_length. exact Hx. - + unfold test_def in Hy. apply andb_and in Hy. - destruct Hy as [_ Hy]. + rewrite <- shiftnP_add. + rewrite fix_context_length. exact Hx. + + unfold test_def in Hy. apply andb_and in Hy. + destruct Hy as [_ Hy]. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite fix_context_length. + rewrite <- shiftnP_add. + rewrite fix_context_length. rewrite (All2_length X). exact Hy. - cbn. repeat rewrite inst_mkApps. eapply cumul_Ind. * repeat rewrite map_length; eauto. - * rename b into Hargs', b0 into Hargs; eapply forallb_All in Hargs, Hargs'. - apply (All2_All_mix_left Hargs) in X. clear Hargs. + * rename b into Hargs', b0 into Hargs; eapply forallb_All in Hargs, Hargs'. + apply (All2_All_mix_left Hargs) in X. clear Hargs. apply (All2_All_mix_right Hargs') in X. clear Hargs'. apply All2_map. eapply All2_impl. 1: tea. cbn; intros. - destruct X0 as [[Hx [Hxy_ Hxy]] Hy]. + destruct X0 as [[Hx [Hxy_ Hxy]] Hy]. eapply Hxy; eauto. - cbn. repeat rewrite inst_mkApps. eapply cumul_Construct. * repeat rewrite map_length; eauto. - * rename b into Hargs', b0 into Hargs; eapply forallb_All in Hargs, Hargs'. - apply (All2_All_mix_left Hargs) in X. clear Hargs. + * rename b into Hargs', b0 into Hargs; eapply forallb_All in Hargs, Hargs'. + apply (All2_All_mix_left Hargs) in X. clear Hargs. apply (All2_All_mix_right Hargs') in X. clear Hargs'. apply All2_map. eapply All2_impl. 1: tea. cbn; intros. - destruct X0 as [[Hx [Hxy_ Hxy]] Hy]. - eapply Hxy; eauto. + destruct X0 as [[Hx [Hxy_ Hxy]] Hy]. + eapply Hxy; eauto. - eapply cumul_Sort; eauto. - eapply cumul_Const; eauto. -Defined. - +Defined. + Lemma inst_convSpec {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ σ A B} : closed_subst Γ σ Δ -> is_closed_context Γ -> @@ -347,7 +347,7 @@ Lemma inst_convSpec {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} { is_open_term Γ B -> Σ ;;; Γ |- A =s B -> Σ ;;; Δ |- A.[σ] =s B.[σ]. -Proof. +Proof. apply inst_cumulSpec. Qed. @@ -574,7 +574,7 @@ Proof. - intros Σ wfΣ Γ wfΓ p pty cdecl _ hp hdecl pinv Δ σ hΔ hσ. cbn. econstructor; tea. - + - intros Σ wfΣ Γ wfΓ t A B X hwf ht iht hB ihB hcum Δ σ hΔ hσ. eapply type_Cumul. + eapply iht. all: auto. diff --git a/pcuic/theories/Typing/PCUICNamelessTyp.v b/pcuic/theories/Typing/PCUICNamelessTyp.v index 3d113bf85..68fc5c142 100644 --- a/pcuic/theories/Typing/PCUICNamelessTyp.v +++ b/pcuic/theories/Typing/PCUICNamelessTyp.v @@ -13,8 +13,8 @@ Implicit Types cf : checker_flags. (** Typing does not rely on name annotations of binders. - We prove this by constructing a type-preserving translation to - terms where all binders are anonymous. An alternative would be to + We prove this by constructing a type-preserving translation to + terms where all binders are anonymous. An alternative would be to be parametrically polymorphic everywhere on the binder name type. This would allow to add implicit information too. *) @@ -85,7 +85,7 @@ Qed. Lemma nl_wf_cofixpoint Σ mfix : wf_cofixpoint Σ.1 mfix = wf_cofixpoint (nlg Σ) (map (map_def_anon nl nl) mfix). Proof. - unfold wf_cofixpoint, wf_cofixpoint_gen. + unfold wf_cofixpoint, wf_cofixpoint_gen. replace (map check_one_cofix mfix) with (map check_one_cofix (map (map_def_anon nl nl) mfix)) => //. * destruct map_option_out => //. destruct l => //. f_equal. rewrite /check_recursivity_kind. @@ -107,7 +107,7 @@ Qed. (* Seems unused *) (* -Lemma nl_wf {cf:checker_flags} (Σ : global_env_ext) : +Lemma nl_wf {cf:checker_flags} (Σ : global_env_ext) : wf Σ -> wf (nlg Σ). Lemma nl_cumulSpec {cf:checker_flags} : @@ -118,18 +118,18 @@ Lemma nl_cumulSpec {cf:checker_flags} : Σ ;;; Γ |- A <=s B -> nlg Σ ;;; nlctx Γ |- nl A <=s nl B. Proof. - intros. eapply (cumulAlgo_cumulSpec (nlg Σ) (pb:=Cumul)). + intros. eapply (cumulAlgo_cumulSpec (nlg Σ) (pb:=Cumul)). eapply into_ws_cumul_pb. - - eapply nl_cumul. eapply (ws_cumul_pb_forget (pb:=Cumul)). - unshelve eapply (cumulSpec_cumulAlgo _ _ (exist _ _ ) (exist _ _) (exist _ _)); eauto; cbn. - - eapply closed_ctx_on_free_vars. apply closed_nlctx. + - eapply nl_cumul. eapply (ws_cumul_pb_forget (pb:=Cumul)). + unshelve eapply (cumulSpec_cumulAlgo _ _ (exist _ _ ) (exist _ _) (exist _ _)); eauto; cbn. + - eapply closed_ctx_on_free_vars. apply closed_nlctx. rewrite is_closed_ctx_closed; eauto. - eapply closedn_on_free_vars. apply closed_nl. rewrite nlctx_length. rewrite on_free_vars_closedn; eauto. - eapply closedn_on_free_vars. apply closed_nl. rewrite nlctx_length. rewrite on_free_vars_closedn; eauto. - Unshelve. eapply nl_wf; eauto. -Defined. + Unshelve. eapply nl_wf; eauto. +Defined. Lemma typing_nlg {cf : checker_flags} : env_prop (fun Σ Γ t T => nlg Σ ;;; nlctx Γ |- nl t : nl T) @@ -287,8 +287,8 @@ Proof. now rewrite -> XX, <- nl_lift. + now rewrite <-nl_wf_cofixpoint. - econstructor; tea. - apply nl_cumulSpec; eauto. - + eapply wf_local_closed_context; eauto. + apply nl_cumulSpec; eauto. + + eapply wf_local_closed_context; eauto. + eapply closedn_on_free_vars. eapply type_closed; eauto. + eapply closedn_on_free_vars. eapply subject_closed; eauto. Qed. diff --git a/pcuic/theories/Typing/PCUICRenameTyp.v b/pcuic/theories/Typing/PCUICRenameTyp.v index 1c3e765d4..cfd8ec1b3 100644 --- a/pcuic/theories/Typing/PCUICRenameTyp.v +++ b/pcuic/theories/Typing/PCUICRenameTyp.v @@ -3,7 +3,7 @@ From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICCases PCUICInduction PCUICLiftSubst PCUICUnivSubst PCUICCumulativity - PCUICTyping PCUICReduction PCUICGlobalEnv PCUICClosed PCUICEquality PCUICRenameDef + PCUICTyping PCUICReduction PCUICGlobalEnv PCUICClosed PCUICEquality PCUICRenameDef PCUICSigmaCalculus PCUICClosed PCUICOnFreeVars PCUICOnFreeVarsConv PCUICGuardCondition PCUICTyping PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICClosedConv PCUICClosedTyp PCUICRenameConv. @@ -66,7 +66,7 @@ Proof. - rewrite rename_context_subst. rewrite rename_closed_extended_subst //. f_equal. rewrite shiftn_add Nat.add_comm. len. - rewrite rename_context_lift. f_equal. + rewrite rename_context_lift. f_equal. rewrite rename_closedn_ctx //. Qed. @@ -160,8 +160,8 @@ Lemma cumulSpec_renameP pb P Σ Γ Δ f A B : let sP := shiftnP #|Γ| P in is_closed_context Δ -> Σ ;;; Γ ⊢ A ≤s[pb] B -> Σ ;;; Δ ⊢ rename f A ≤s[pb] rename f B. -Proof. - intros sP wfΣ Hren HfreeA HfreeB HΓ HΔ e. +Proof. + intros sP wfΣ Hren HfreeA HfreeB HΓ HΔ e. revert pb Γ A B e sP Δ f wfΣ Hren HfreeA HfreeB HΓ HΔ e. apply: (cumulSpec0_ind_all Σ); intros; cbn. - rewrite rename_subst10. solve [econstructor]. @@ -170,7 +170,7 @@ Proof. destruct (nth_error Γ i) eqn:hnth; noconf H. assert (hav : sP i). { unfold sP, shiftnP in *. cbn in *. rewrite orb_false_r in HfreeB. intuition. } - clear HfreeB. + clear HfreeB. specialize hf with (1 := hav) (2 := hnth). destruct hf as [decl' [e' [eqann [hr hbo]]]]. rewrite H /= in hbo. @@ -204,111 +204,111 @@ Proof. eapply cumul_cofix_proj. eapply rename_unfold_cofix. eassumption. - rewrite rename_subst_instance. - eapply cumul_delta. + eapply cumul_delta. + eassumption. + rewrite rename_closed. 2: assumption. eapply declared_constant_closed_body. all: eauto. - rewrite rename_mkApps. simpl. eapply cumul_proj. rewrite nth_error_map. rewrite H. reflexivity. - - eapply cumul_Trans; try apply X0; try apply X2; eauto. eapply urename_is_open_term; eauto. + - eapply cumul_Trans; try apply X0; try apply X2; eauto. eapply urename_is_open_term; eauto. - eapply cumul_Sym; intuition; eauto. - eapply cumul_Refl; intuition; eauto. - - eapply cumul_Evar. cbn in *. - apply forallb_All in HfreeB, HΓ. + - eapply cumul_Evar. cbn in *. + apply forallb_All in HfreeB, HΓ. eapply All2_All_mix_left in X; tea. eapply All2_All_mix_right in X; tea. eapply All2_map. eapply All2_impl. 1:tea. cbn; intros. eapply X0.1.2; intuition. - cbn in *. rtoProp. - eapply cumul_App; try apply X0; try apply X2; eauto. + eapply cumul_App; try apply X0; try apply X2; eauto. - cbn in HfreeB, HΓ; rtoProp. eapply cumul_Lambda; try apply X0; try apply X2; eauto; - try rewrite shiftnP_S; eauto. - * eapply urenaming_impl. 1: intro; rewrite shiftnP_S; eauto. apply urenaming_vass; eauto. + try rewrite shiftnP_S; eauto. + * eapply urenaming_impl. 1: intro; rewrite shiftnP_S; eauto. apply urenaming_vass; eauto. * rewrite on_free_vars_ctx_snoc. apply andb_and; split; eauto. * rewrite on_free_vars_ctx_snoc. apply andb_and; split; eauto. - cbn. eapply urename_is_open_term; eauto. + cbn. eapply urename_is_open_term; eauto. - cbn in HfreeB, HΓ. rtoProp. eapply cumul_Prod; try apply X0; try apply X2; eauto; try rewrite shiftnP_S; eauto. - * eapply urenaming_impl. 1: intro; rewrite shiftnP_S; eauto. apply urenaming_vass; eauto. + * eapply urenaming_impl. 1: intro; rewrite shiftnP_S; eauto. apply urenaming_vass; eauto. * rewrite on_free_vars_ctx_snoc. apply andb_and; split; eauto. * rewrite on_free_vars_ctx_snoc. apply andb_and; split; eauto. - cbn. eapply urename_is_open_term; eauto. + cbn. eapply urename_is_open_term; eauto. - cbn in HfreeB, HΓ; rtoProp. - eapply cumul_LetIn; try apply X0; try apply X2; eauto; try apply X4; + eapply cumul_LetIn; try apply X0; try apply X2; eauto; try apply X4; try rewrite shiftnP_S; eauto. - * eapply urenaming_impl. 1: intro; rewrite shiftnP_S; eauto. apply urenaming_vdef; eauto. + * eapply urenaming_impl. 1: intro; rewrite shiftnP_S; eauto. apply urenaming_vdef; eauto. + * rewrite on_free_vars_ctx_snoc_def; eauto. * rewrite on_free_vars_ctx_snoc_def; eauto. - * rewrite on_free_vars_ctx_snoc_def; eauto. all: eapply urename_is_open_term; eauto. - - cbn in HfreeB, HΓ. - rename HΓ into H'; rename HfreeB into H. + - cbn in HfreeB, HΓ. + rename HΓ into H'; rename HfreeB into H. apply andb_andI in H; apply andb_andI in H'; destruct H as [Hp H]; destruct H' as [Hp' H']. apply andb_andI in H; apply andb_andI in H'; destruct H as [Hreturn H]; destruct H' as [Hreturn' H']. apply andb_andI in H; apply andb_andI in H'; destruct H as [Hcontext H]; destruct H' as [Hcontext' H']. - apply andb_andI in H; apply andb_andI in H'; destruct H as [Hc Hbrs]; destruct H' as [Hc' Hbrs']. + apply andb_andI in H; apply andb_andI in H'; destruct H as [Hc Hbrs]; destruct H' as [Hc' Hbrs']. eapply cumul_Case. * unfold cumul_predicate. unfold cumul_predicate in X. destruct X as [Xparam [Xuniv [Xcontext [Xeq Xreturn]]]]. - repeat split; eauto. - + eapply All2_map. apply forallb_All in Hp, Hp'. eapply (All2_All_mix_left Hp) in Xparam. + repeat split; eauto. + + eapply All2_map. apply forallb_All in Hp, Hp'. eapply (All2_All_mix_left Hp) in Xparam. eapply (All2_All_mix_right Hp') in Xparam. eapply All2_impl. 1: tea. cbn; intros. destruct X as [[X [X''' X']] X'']. apply X'; eauto. + unfold preturn. cbn. rewrite (All2_fold_length Xcontext). eapply Xreturn; eauto. ++ rewrite app_context_length. - eapply urenaming_ext; try apply shiftnP_add; try reflexivity. + eapply urenaming_ext; try apply shiftnP_add; try reflexivity. rewrite <- (All2_fold_length Xcontext). rewrite <- inst_case_predicate_context_length. - rewrite test_context_k_closed_on_free_vars_ctx in Hcontext. - rewrite inst_case_predicate_context_rename; eauto. + rewrite test_context_k_closed_on_free_vars_ctx in Hcontext. + rewrite inst_case_predicate_context_rename; eauto. apply urenaming_context; eauto. ++ rewrite test_context_k_closed_on_free_vars_ctx in Hcontext. - unfold inst_case_predicate_context. + unfold inst_case_predicate_context. apply on_free_vars_ctx_inst_case_context; eauto. ++ unfold inst_case_predicate_context. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite inst_case_predicate_context_length. + rewrite <- shiftnP_add. + rewrite inst_case_predicate_context_length. eassumption. ++ unfold inst_case_predicate_context. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite inst_case_predicate_context_length. + rewrite <- shiftnP_add. + rewrite inst_case_predicate_context_length. rewrite (All2_fold_length Xcontext). eassumption. ++ rewrite test_context_k_closed_on_free_vars_ctx in Hcontext. unfold inst_case_predicate_context. apply on_free_vars_ctx_inst_case_context; eauto. +++ eapply All_forallb. apply All_map. apply forallb_All in Hp; eapply All_impl. 1: tea. cbn; intros. eapply urename_is_open_term; eauto. +++ unfold pparams. cbn. rewrite map_length. exact Hcontext. - * apply X1; eauto. + * apply X1; eauto. * rename X2 into Hbrsbrs'. - apply forallb_All in Hbrs, Hbrs'. apply (All2_All_mix_left Hbrs) in Hbrsbrs'. clear Hbrs. + apply forallb_All in Hbrs, Hbrs'. apply (All2_All_mix_left Hbrs) in Hbrsbrs'. clear Hbrs. apply (All2_All_mix_right Hbrs') in Hbrsbrs'. clear Hbrs'. apply All2_map. eapply All2_impl. 1: tea. cbn; intros x y [[Hx Heqxy ] Hy]. destruct Heqxy as [[Hbcontext Hbody] Heqxy]. rewrite (All2_fold_length Hbcontext). - split; eauto. + split; eauto. apply andb_and in Hx. destruct Hx as [Hx Hbodyx]. apply andb_and in Hy. destruct Hy as [Hy Hbodyy]. apply Heqxy; eauto. + rewrite app_context_length. - eapply urenaming_ext; try apply shiftnP_add; try reflexivity. + eapply urenaming_ext; try apply shiftnP_add; try reflexivity. rewrite <- (All2_fold_length Hbcontext). rewrite <- (inst_case_branch_context_length p). - rewrite test_context_k_closed_on_free_vars_ctx in Hx. - rewrite inst_case_branch_context_rename; eauto. + rewrite test_context_k_closed_on_free_vars_ctx in Hx. + rewrite inst_case_branch_context_rename; eauto. apply urenaming_context; eauto. + rewrite test_context_k_closed_on_free_vars_ctx in Hx. unfold inst_case_predicate_context. apply on_free_vars_ctx_inst_case_context; eauto. + unfold inst_case_predicate_context. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite inst_case_branch_context_length. + rewrite <- shiftnP_add. + rewrite inst_case_branch_context_length. eassumption. + unfold inst_case_predicate_context. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite inst_case_branch_context_length. + rewrite <- shiftnP_add. + rewrite inst_case_branch_context_length. rewrite (All2_fold_length Hbcontext). eassumption. + rewrite test_context_k_closed_on_free_vars_ctx in Hcontext. unfold inst_case_predicate_context. apply on_free_vars_ctx_inst_case_context; eauto. @@ -319,121 +319,121 @@ Proof. - cbn in *. eapply cumul_Proj; try apply X0; eauto. - rewrite (All2_length X). eapply cumul_Fix. cbn in *. - apply forallb_All in HfreeB, HΓ. - apply (All2_All_mix_left HfreeB) in X. clear HfreeB. + apply forallb_All in HfreeB, HΓ. + apply (All2_All_mix_left HfreeB) in X. clear HfreeB. apply (All2_All_mix_right HΓ) in X. clear HΓ. apply All2_map. eapply All2_impl. 1: tea. cbn; intros. destruct X0 as [[Hx [[[_Htype [Htype Hbody_]] [Hbody Harg]] Hname]] Hy]. repeat split; eauto. - * eapply Htype; eauto. + * eapply Htype; eauto. + cbn in Hx; eapply andb_and in Hx. intuition. + cbn in Hy; eapply andb_and in Hy. intuition. - * eapply Hbody; eauto. + * eapply Hbody; eauto. + rewrite app_context_length. - eapply urenaming_ext; try apply shiftnP_add; try reflexivity. + eapply urenaming_ext; try apply shiftnP_add; try reflexivity. rewrite <- (All2_length X). rewrite rename_fix_context. rewrite <- fix_context_length. - apply urenaming_context; eauto. - + rewrite on_free_vars_ctx_app. + apply urenaming_context; eauto. + + rewrite on_free_vars_ctx_app. apply andb_and; split; eauto. apply on_free_vars_fix_context. eapply All2_All_left. 1: tea. cbn; intros. - apply X0.1. - + unfold test_def in Hx. apply andb_and in Hx. - destruct Hx as [_ Hx]. + apply X0.1. + + unfold test_def in Hx. apply andb_and in Hx. + destruct Hx as [_ Hx]. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite fix_context_length. exact Hx. - + unfold test_def in Hy. apply andb_and in Hy. - destruct Hy as [_ Hy]. + rewrite <- shiftnP_add. + rewrite fix_context_length. exact Hx. + + unfold test_def in Hy. apply andb_and in Hy. + destruct Hy as [_ Hy]. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite fix_context_length. - rewrite (All2_length X). exact Hy. - + rewrite on_free_vars_ctx_app. + rewrite <- shiftnP_add. + rewrite fix_context_length. + rewrite (All2_length X). exact Hy. + + rewrite on_free_vars_ctx_app. apply andb_and; split; eauto. apply on_free_vars_fix_context. - apply All_map. + apply All_map. eapply All2_All_left. 1: tea. cbn ; intros. destruct X0 as [[Hx0 _] _]. unfold test_def. unfold test_def in Hx0. apply andb_and in Hx0. destruct Hx0 as [Hx0type Hx0body]. - apply andb_and. cbn. split. + apply andb_and. cbn. split. ++ eapply urename_is_open_term; eauto. ++ rewrite map_length. rewrite <-(All2_length X). rewrite <- fix_context_length. eapply urename_on_free_vars_shift; eauto. - rewrite fix_context_length; eauto. + rewrite fix_context_length; eauto. - rewrite (All2_length X). eapply cumul_CoFix. cbn in *. - apply forallb_All in HfreeB, HΓ. - apply (All2_All_mix_left HfreeB) in X. clear HfreeB. + apply forallb_All in HfreeB, HΓ. + apply (All2_All_mix_left HfreeB) in X. clear HfreeB. apply (All2_All_mix_right HΓ) in X. clear HΓ. apply All2_map. eapply All2_impl. 1: tea. cbn; intros. destruct X0 as [[Hx [[[_Htype [Htype Hbody_]] [Hbody Harg]] Hname]] Hy]. repeat split; eauto. - * eapply Htype; eauto. + * eapply Htype; eauto. + cbn in Hx; eapply andb_and in Hx. intuition. + cbn in Hy; eapply andb_and in Hy. intuition. - * eapply Hbody; eauto. + * eapply Hbody; eauto. + rewrite app_context_length. - eapply urenaming_ext; try apply shiftnP_add; try reflexivity. + eapply urenaming_ext; try apply shiftnP_add; try reflexivity. rewrite <- (All2_length X). rewrite rename_fix_context. rewrite <- fix_context_length. - apply urenaming_context; eauto. - + rewrite on_free_vars_ctx_app. + apply urenaming_context; eauto. + + rewrite on_free_vars_ctx_app. apply andb_and; split; eauto. apply on_free_vars_fix_context. eapply All2_All_left. 1: tea. cbn; intros. - apply X0.1. - + unfold test_def in Hx. apply andb_and in Hx. - destruct Hx as [_ Hx]. + apply X0.1. + + unfold test_def in Hx. apply andb_and in Hx. + destruct Hx as [_ Hx]. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite fix_context_length. exact Hx. - + unfold test_def in Hy. apply andb_and in Hy. - destruct Hy as [_ Hy]. + rewrite <- shiftnP_add. + rewrite fix_context_length. exact Hx. + + unfold test_def in Hy. apply andb_and in Hy. + destruct Hy as [_ Hy]. unfold is_open_term. rewrite app_length. - rewrite <- shiftnP_add. - rewrite fix_context_length. - rewrite (All2_length X). exact Hy. - + rewrite on_free_vars_ctx_app. + rewrite <- shiftnP_add. + rewrite fix_context_length. + rewrite (All2_length X). exact Hy. + + rewrite on_free_vars_ctx_app. apply andb_and; split; eauto. apply on_free_vars_fix_context. - apply All_map. + apply All_map. eapply All2_All_left. 1: tea. cbn ; intros. destruct X0 as [[Hx0 _] _]. unfold test_def. unfold test_def in Hx0. apply andb_and in Hx0. destruct Hx0 as [Hx0type Hx0body]. - apply andb_and. cbn. split. + apply andb_and. cbn. split. ++ eapply urename_is_open_term; eauto. ++ rewrite map_length. rewrite <-(All2_length X). rewrite <- fix_context_length. eapply urename_on_free_vars_shift; eauto. - rewrite fix_context_length; eauto. + rewrite fix_context_length; eauto. - repeat rewrite rename_mkApps. eapply cumul_Ind. * repeat rewrite map_length; eauto. * inv_on_free_vars. eapply forallb_All in b, b0. - apply (All2_All_mix_left b0) in X. clear b0. + apply (All2_All_mix_left b0) in X. clear b0. apply (All2_All_mix_right b) in X. clear b. apply All2_map. eapply All2_impl. 1: tea. cbn; intros. - destruct X0 as [[Hx [Hxy_ Hxy]] Hy]. + destruct X0 as [[Hx [Hxy_ Hxy]] Hy]. eapply Hxy; eauto. - repeat rewrite rename_mkApps. eapply cumul_Construct. * repeat rewrite map_length; eauto. * inv_on_free_vars. rename b into Hargs', b0 into Hargs. - eapply forallb_All in Hargs, Hargs'. - apply (All2_All_mix_left Hargs) in X. clear Hargs. + eapply forallb_All in Hargs, Hargs'. + apply (All2_All_mix_left Hargs) in X. clear Hargs. apply (All2_All_mix_right Hargs') in X. clear Hargs'. apply All2_map. eapply All2_impl. 1: tea. cbn; intros. - destruct X0 as [[Hx [Hxy_ Hxy]] Hy]. - eapply Hxy; eauto. + destruct X0 as [[Hx [Hxy_ Hxy]] Hy]. + eapply Hxy; eauto. - eapply cumul_Sort; eauto. - eapply cumul_Const; eauto. -Defined. +Defined. Lemma convSpec_renameP P Σ Γ Δ f A B : let sP := shiftnP #|Γ| P in wf Σ.1 -> @@ -444,7 +444,7 @@ Lemma convSpec_renameP P Σ Γ Δ f A B : let sP := shiftnP #|Γ| P in is_closed_context Δ -> Σ ;;; Γ |- A =s B -> Σ ;;; Δ |- rename f A =s rename f B. -Proof. +Proof. apply cumulSpec_renameP. Qed. @@ -681,7 +681,7 @@ Proof. - simpl. unfold rename_context, fold_context_k; simpl; rewrite nth_error_nil. easy. - simpl. destruct n; rewrite rename_context_snoc. + simpl. lia_f_equal. - + simpl. rewrite IHΓ; simpl in *. + + simpl. rewrite IHΓ; simpl in *. assert (e : #|Γ| - S n = S #|Γ| - S (S n)). { lia. } rewrite e. reflexivity. Qed. @@ -733,7 +733,7 @@ Proof. unfold wf_fixpoint, wf_fixpoint_gen. rewrite forallb_map. move/andP => [] hmfix ho. - apply/andP; split. + apply/andP; split. { eapply forallb_impl; tea. intros. cbn in H0. now eapply isLambda_rename. } move: ho. @@ -1053,13 +1053,13 @@ Proof. + eapply ihB; tea. + eapply cumulSpec_renameP. all: try eassumption. * apply hf. - * apply wf_local_closed_context; eauto. - * pose proof (type_closed ht). - now eapply closedn_on_free_vars in H. + * apply wf_local_closed_context; eauto. + * pose proof (type_closed ht). + now eapply closedn_on_free_vars in H. * pose proof (subject_closed htB). now eapply closedn_on_free_vars in H. * pose proof (closed_ctx_on_free_vars P _ (closed_wf_local _ (typing_wf_local ht))). - destruct hf as [HΔ _]. apply wf_local_closed_context; eauto. + destruct hf as [HΔ _]. apply wf_local_closed_context; eauto. Qed. Lemma typing_rename_P {P Σ Γ Δ f t A} {wfΣ : wf Σ.1} : diff --git a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v index 4e349e90c..439e2e807 100644 --- a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v +++ b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v @@ -52,7 +52,7 @@ Proof. reflexivity. - rewrite subst_instance_mkApps. cbn. rewrite iota_red_subst_instance. - change (bcontext br) with (bcotext (map_branch (subst_instance u) br)). + change (bcontext br) with (bcotext (map_branch (subst_instance u) br)). eapply cumul_iota; eauto with pcuic. * rewrite nth_error_map H //. * simpl. now len. @@ -62,7 +62,7 @@ Proof. * inversion H. rewrite nth_error_map E. cbn. destruct d. cbn in *. cbn in *; try congruence. - f_equal. f_equal. + f_equal. f_equal. now rewrite subst_instance_subst fix_subst_instance_subst. * inversion H. + unfold is_constructor in *. @@ -92,35 +92,35 @@ Proof. eapply cumul_proj. now rewrite nth_error_map H. - eapply cumul_Trans; intuition. * rewrite on_free_vars_ctx_subst_instance; eauto. - * rewrite on_free_vars_subst_instance. unfold is_open_term. + * rewrite on_free_vars_subst_instance. unfold is_open_term. replace #|Γ@[u]| with #|Γ|; eauto. rewrite map_length; eauto. - - eapply cumul_Evar. eapply All2_map. + - eapply cumul_Evar. eapply All2_map. eapply All2_impl. 1: tea. cbn; intros. eapply X0.2; eauto. - - eapply cumul_Case; try solve [intuition; eauto]. - * destruct X as [X [Xuni [Xcont [_ Xret]]]]. repeat split; eauto; cbn. + - eapply cumul_Case; try solve [intuition; eauto]. + * destruct X as [X [Xuni [Xcont [_ Xret]]]]. repeat split; eauto; cbn. + apply All2_map. eapply All2_impl. 1: tea. cbn; intros. eapply X3.2; eauto. + apply precompose_subst_instance. eapply R_universe_instance_impl; eauto. now apply eq_universe_subst_instance. + rewrite subst_instance_app inst_case_predicate_context_subst_instance in Xret. - eapply Xret; eauto. + eapply Xret; eauto. * eapply All2_map. eapply All2_impl. 1: tea. cbn; intros. repeat split; eauto; intuition. - rewrite subst_instance_app inst_case_branch_context_subst_instance in X1; eauto. - - eapply cumul_Fix. apply All2_map. eapply All2_impl. 1: tea. - cbn; intros; intuition. - rewrite subst_instance_app fix_context_subst_instance in X0; eauto. - - eapply cumul_CoFix. apply All2_map. eapply All2_impl. 1: tea. - cbn; intros; intuition. - rewrite subst_instance_app fix_context_subst_instance in X0; eauto. + rewrite subst_instance_app inst_case_branch_context_subst_instance in X1; eauto. + - eapply cumul_Fix. apply All2_map. eapply All2_impl. 1: tea. + cbn; intros; intuition. + rewrite subst_instance_app fix_context_subst_instance in X0; eauto. + - eapply cumul_CoFix. apply All2_map. eapply All2_impl. 1: tea. + cbn; intros; intuition. + rewrite subst_instance_app fix_context_subst_instance in X0; eauto. - repeat rewrite subst_instance_mkApps. eapply cumul_Ind. - * apply precompose_subst_instance_global. + * apply precompose_subst_instance_global. rewrite map_length. eapply R_global_instance_impl_same_napp; try eapply H; eauto. { now apply eq_universe_subst_instance. } { now apply compare_universe_subst_instance. } * eapply All2_map. eapply All2_impl. 1: tea. cbn; intros. eapply X0.2; eauto. - repeat rewrite subst_instance_mkApps. eapply cumul_Construct. - * apply precompose_subst_instance_global. cbn. + * apply precompose_subst_instance_global. cbn. rewrite map_length. eapply R_global_instance_impl_same_napp; try eapply H; eauto. { now apply eq_universe_subst_instance. } { now apply compare_universe_subst_instance. } @@ -129,8 +129,8 @@ Proof. - eapply cumul_Sort. now apply compare_universe_subst_instance. - eapply cumul_Const. apply precompose_subst_instance. eapply R_universe_instance_impl; eauto. - now apply compare_universe_subst_instance. -Defined. + now apply compare_universe_subst_instance. +Defined. Lemma convSpec_subst_instance (Σ : global_env_ext) Γ u A B univs : valid_constraints (global_ext_constraints (Σ.1, univs)) @@ -185,7 +185,7 @@ Qed. Hint Resolve subst_instance_cstrs_two satisfies_equal_sets satisfies_subsets : univ_subst. -Hint Resolve monomorphic_global_constraint monomorphic_global_constraint_ext : univ_subst. +Hint Resolve monomorphic_global_constraint monomorphic_global_constraint_ext : univ_subst. Hint Unfold CS.For_all : univ_subst. Hint Resolve consistent_ext_trans : univ_subst. Hint Resolve consistent_instance_valid_constraints : univ_subst. @@ -278,9 +278,9 @@ Proof using Type. rewrite subst_instance_case_predicate_context. eapply type_Case with (p:=subst_instance i p) (ps:=subst_instance_univ i u); eauto with pcuic. - 3,4: constructor; eauto with pcuic. + 3,4: constructor; eauto with pcuic. + rewrite -subst_instance_case_predicate_context - !subst_instance_app_ctx. - eapply Hpty; eauto. + eapply Hpty; eauto. + eapply IHc in cu => //. now rewrite subst_instance_mkApps map_app in cu. + simpl. eapply consistent_ext_trans; tea. @@ -294,7 +294,7 @@ Proof using Type. clear -wfext cu. induction 1; try destruct t0; cbn; constructor; simpl; eauto. all:now rewrite -(subst_instance_subst_telescope i [_]). + rewrite -{1}(map_id (ind_ctors idecl)). - eapply All2i_map. eapply All2i_impl; eauto. + eapply All2i_map. eapply All2i_impl; eauto. cbn -[case_branch_type case_branch_context subst_instance]. intros k cdecl br (hctx & hcbctx & (hbod & ihbod) & hbty & ihbty). rewrite case_branch_type_fst. @@ -325,19 +325,19 @@ Proof using Type. eapply infer_typing_sort_impl with (tu := X1). intros [_ Hs]; now apply Hs. + eapply All_map, All_impl; tea. - intros x [X1 X3]. - specialize (X3 u univs wfΣ' H2). + intros x [X1 X3]. + specialize (X3 u univs wfΣ' H2). rewrite (map_dbody (subst_instance u)) in X3. rewrite subst_instance_lift in X3. rewrite fix_context_length ?map_length in X0, X1, X3. rewrite (map_dtype _ (subst_instance u) x) in X3. rewrite subst_instance_app in X3. - rewrite <- (fix_context_subst_instance u mfix). + rewrite <- (fix_context_subst_instance u mfix). now len. + red; rewrite <- wffix. unfold wf_fixpoint, wf_fixpoint_gen. - f_equal. - { rewrite forallb_map. solve_all. cbn. + f_equal. + { rewrite forallb_map. solve_all. cbn. destruct (dbody x) => //. } rewrite map_map_compose. now rewrite subst_instance_check_one_fix. @@ -353,14 +353,14 @@ Proof using Type. eapply infer_typing_sort_impl with (tu := X1). intros [_ Hs]; now apply Hs. + eapply All_map, All_impl; tea. - intros x [X1 X3]. - specialize (X3 u univs wfΣ' H2). + intros x [X1 X3]. + specialize (X3 u univs wfΣ' H2). rewrite (map_dbody (subst_instance u)) in X3. rewrite subst_instance_lift in X3. rewrite fix_context_length ?map_length in X0, X1, X3. rewrite (map_dtype _ (subst_instance u) x) in X3. rewrite subst_instance_app in X3. - rewrite <- (fix_context_subst_instance u mfix). + rewrite <- (fix_context_subst_instance u mfix). now len. + red; rewrite <- wffix. unfold wf_cofixpoint, wf_cofixpoint_gen. @@ -438,32 +438,32 @@ Qed. -Lemma wf_local_instantiate_poly {Σ ctx Γ u} : +Lemma wf_local_instantiate_poly {Σ ctx Γ u} : wf_ext (Σ.1, Polymorphic_ctx ctx) -> consistent_instance_ext Σ (Polymorphic_ctx ctx) u -> - wf_local (Σ.1, Polymorphic_ctx ctx) Γ -> + wf_local (Σ.1, Polymorphic_ctx ctx) Γ -> wf_local Σ (subst_instance u Γ). Proof using Type. intros wfΣ Huniv wf. epose proof (type_Sort _ _ Universes.Universe.lProp wf) as ty. forward ty. - now simpl. - - eapply typing_subst_instance_ctx in ty; - cbn; eauto using typing_wf_local. + - eapply typing_subst_instance_ctx in ty; + cbn; eauto using typing_wf_local. * apply wfΣ. * destruct wfΣ. now eapply on_udecl_on_udecl_prop. Qed. -Lemma wf_local_instantiate {Σ} {decl : global_decl} {Γ u c} : +Lemma wf_local_instantiate {Σ} {decl : global_decl} {Γ u c} : wf Σ.1 -> lookup_env Σ.1 c = Some decl -> consistent_instance_ext Σ (universes_decl_of_decl decl) u -> - wf_local (Σ.1, universes_decl_of_decl decl) Γ -> + wf_local (Σ.1, universes_decl_of_decl decl) Γ -> wf_local Σ (subst_instance u Γ). Proof using Type. intros wfΣ Hdecl Huniv wf. epose proof (type_Sort _ _ Universes.Universe.lProp wf) as ty. forward ty. - now simpl. - - eapply typing_subst_instance_decl in ty; + - eapply typing_subst_instance_decl in ty; cbn; eauto using typing_wf_local. Qed. diff --git a/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v b/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v index db28e6b51..91a6f4ab4 100644 --- a/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v +++ b/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v @@ -74,7 +74,7 @@ Qed. #[global] Hint Resolve extends_wf_fixpoint extends_wf_cofixpoint : extends. -Lemma extends_primitive_constant Σ Σ' p t : +Lemma extends_primitive_constant Σ Σ' p t : extends Σ Σ' -> primitive_constant Σ p = Some t -> primitive_constant Σ' p = Some t. @@ -298,7 +298,7 @@ Proof. exists (Σ'' ++ [(kn, d)]). now rewrite <- app_assoc. } case: eqb_specT; intro eq; subst. - - intros [= ->]. subst. destruct o. + - intros [= ->]. subst. destruct o. clear Hext; eapply weakening_on_global_decl_ext. 3:tea. all:eauto. - destruct o. apply IHonΣ; auto. destruct wfΣ. split => //. now depelim o0. @@ -318,8 +318,8 @@ Proof. destruct Hext as [univs' [Σ'' HΣ'']]. split; eauto. exists (Σ'' ++ [(kn, d)]). now rewrite <- app_assoc. } - destruct o. case: eqb_specT; intro e; subst. - - intros [= ->]. subst. + destruct o. case: eqb_specT; intro e; subst. + - intros [= ->]. subst. clear Hext; eapply weakening_on_global_decl. 5:tea. all:eauto. destruct wfΣ. split => //. now depelim o0. - apply IHonΣ; auto. @@ -333,7 +333,7 @@ Lemma weaken_lookup_on_global_env `{checker_flags} P Σ c decl : on_global_decl cumulSpec0 P (Σ, universes_decl_of_decl decl) c decl. Proof. intros. eapply weakening_env_lookup_on_global_env; eauto. - split => //. + split => //. - split; [lsets|csets]. - exists []; simpl; destruct Σ; eauto. - apply Retroknowledge.extends_refl. @@ -346,7 +346,7 @@ Lemma weaken_decls_lookup_on_global_env `{checker_flags} P Σ c decl : on_global_decl cumulSpec0 P (Σ, universes_decl_of_decl decl) c decl. Proof. intros. eapply weakening_env_decls_lookup_on_global_env; eauto. - split => //. + split => //. - exists []; simpl; destruct Σ; eauto. Qed. diff --git a/pcuic/theories/Typing/PCUICWeakeningTyp.v b/pcuic/theories/Typing/PCUICWeakeningTyp.v index a3f7dff4f..370741401 100644 --- a/pcuic/theories/Typing/PCUICWeakeningTyp.v +++ b/pcuic/theories/Typing/PCUICWeakeningTyp.v @@ -2,7 +2,7 @@ From Coq Require Import Morphisms. From MetaCoq.Template Require Import config utils. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction - PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICCumulativity + PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICCumulativity PCUICClosed PCUICSigmaCalculus PCUICRenameDef PCUICRenameConv PCUICRenameTyp PCUICOnFreeVars PCUICClosedConv PCUICClosedTyp PCUICWeakeningConv. @@ -22,7 +22,7 @@ Generalizable Variables Σ Γ t T. Lemma weakening_wf_local {cf: checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Γ''} : wf_local Σ (Γ ,,, Γ') -> - wf_local Σ (Γ ,,, Γ'') -> + wf_local Σ (Γ ,,, Γ'') -> wf_local Σ (Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ'). Proof. intros wfΓ' wfΓ''. @@ -34,7 +34,7 @@ Proof. eapply (All_local_env_impl_ind XΓ'). intros Δ t [T|] IH; simpl. - intros Hf. rewrite -/(lift_context #|Γ''| 0 Δ). - rewrite Nat.add_0_r. rewrite !lift_rename. + rewrite Nat.add_0_r. rewrite !lift_rename. eapply (Hf xpredT). split. + apply wf_local_app; auto. @@ -42,7 +42,7 @@ Proof. + apply weakening_renaming. - intros Hty. simple apply (infer_typing_sort_impl (P := fun Σ Γ T s => forall P Δ f, renaming _ Σ Δ Γ _ -> Σ;;; Δ |- rename f T : rename f s)) with id Hty; intros Hs. rewrite -/(lift_context #|Γ''| 0 Δ). - rewrite Nat.add_0_r !lift_rename. + rewrite Nat.add_0_r !lift_rename. eapply (Hs xpredT). split. + apply wf_local_app; auto. @@ -62,8 +62,8 @@ Qed. Lemma weakening_rename_typing `{cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Γ''} {t T} : wf_local Σ (Γ ,,, Γ'') -> Σ ;;; Γ ,,, Γ' |- t : T -> - Σ ;;; Γ ,,, Γ'' ,,, rename_context (lift_renaming #|Γ''| 0) Γ' |- - rename (lift_renaming #|Γ''| #|Γ'|) t : + Σ ;;; Γ ,,, Γ'' ,,, rename_context (lift_renaming #|Γ''| 0) Γ' |- + rename (lift_renaming #|Γ''| #|Γ'|) t : rename (lift_renaming #|Γ''| #|Γ'|) T. Proof. intros wfext Ht. @@ -136,7 +136,7 @@ Lemma weakening_length {cf:checker_flags} Σ Γ Γ' t T n : Proof. intros wfΣ ->; now apply weakening. Qed. Lemma weaken_ctx {cf:checker_flags} {Σ Γ t T} Δ : - wf Σ.1 -> + wf Σ.1 -> wf_local Σ Δ -> Σ ;;; Γ |- t : T -> Σ ;;; Δ ,,, Γ |- t : T. @@ -160,9 +160,9 @@ Proof. intros ; subst n; now apply weakening. Qed. -(** Convenience lemma when going through instantiation for renaming. +(** Convenience lemma when going through instantiation for renaming. Δ is arbitrary here, it does not have to be the weakening of some other context. *) -Lemma shift_typing {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ t T n Δ} : +Lemma shift_typing {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ t T n Δ} : Σ ;;; Γ |- t : T -> wf_local Σ (Γ ,,, Δ) -> n = #|Δ| -> @@ -205,7 +205,7 @@ Proof. rewrite app_context_assoc. apply X. Qed. -Lemma isType_lift {cf:checker_flags} {Σ : global_env_ext} {n Γ ty} +Lemma isType_lift {cf:checker_flags} {Σ : global_env_ext} {n Γ ty} (isdecl : n <= #|Γ|): wf Σ -> wf_local Σ Γ -> isType Σ (skipn n Γ) ty -> @@ -216,6 +216,6 @@ Proof. { rewrite firstn_length_le; auto with arith. } apply infer_typing_sort_impl with id wfty; intros Hs. rewrite {3}H. - eapply (weakening_typing (Γ := skipn n Γ) (Γ' := []) (Γ'' := firstn n Γ) (T := tSort _)); + eapply (weakening_typing (Γ := skipn n Γ) (Γ' := []) (Γ'' := firstn n Γ) (T := tSort _)); eauto with wf. Qed. diff --git a/pcuic/theories/utils/PCUICAstUtils.v b/pcuic/theories/utils/PCUICAstUtils.v index 58139441f..d67b0be8d 100644 --- a/pcuic/theories/utils/PCUICAstUtils.v +++ b/pcuic/theories/utils/PCUICAstUtils.v @@ -97,7 +97,7 @@ Proof. intros diff look. intuition auto. Qed. -Lemma lookup_env_cons_fresh {kn d Σ kn'} : +Lemma lookup_env_cons_fresh {kn d Σ kn'} : kn <> kn' -> lookup_global ((kn, d) :: Σ) kn' = lookup_global Σ kn'. Proof. @@ -132,7 +132,7 @@ Qed. Definition mkApps_decompose_app t : t = mkApps (fst (decompose_app t)) (snd (decompose_app t)) := mkApps_decompose_app_rec t []. - + Lemma decompose_app_rec_mkApps f l l' : decompose_app_rec (mkApps f l) l' = decompose_app_rec f (l ++ l'). Proof. @@ -155,8 +155,8 @@ Proof. Qed. -Lemma mkApps_tApp_inj fn args t u : - ~~ isApp fn -> +Lemma mkApps_tApp_inj fn args t u : + ~~ isApp fn -> mkApps fn args = tApp t u -> t = mkApps fn (removelast args) /\ u = last args t. Proof. @@ -173,7 +173,7 @@ Proof. now rewrite (removelast_app [_]) // app_length IHargs /=. Qed. -Lemma nth_error_removelast {A} {args : list A} {n arg} : +Lemma nth_error_removelast {A} {args : list A} {n arg} : nth_error (removelast args) n = Some arg -> nth_error args n = Some arg. Proof. @@ -182,7 +182,7 @@ Proof. now rewrite removelast_length in h. Qed. -Lemma mkApps_discr f args t : +Lemma mkApps_discr f args t : args <> [] -> mkApps f args = t -> ~~ isApp t -> False. @@ -255,7 +255,7 @@ Fixpoint decompose_prod_assum (Γ : context) (t : term) : context * term := | tLetIn na b bty b' => decompose_prod_assum (Γ ,, vdef na b bty) b' | _ => (Γ, t) end. - + Lemma decompose_prod_assum_ctx ctx t : decompose_prod_assum ctx t = let (ctx', t') := decompose_prod_assum [] t in (ctx ,,, ctx', t'). @@ -472,7 +472,7 @@ Lemma decompose_app_inv {t f l} : decompose_app t = (f, l) -> t = mkApps f l. Proof. by apply/decompose_app_rec_inv. Qed. -Lemma decompose_app_nonnil t f l : +Lemma decompose_app_nonnil t f l : isApp t -> decompose_app t = (f, l) -> l <> []. Proof. @@ -680,7 +680,7 @@ Ltac solve_discr' := change t with (mkApps t []) in H ; eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence end. - + Lemma mkApps_eq_decompose_app {t t' l l'} : mkApps t l = mkApps t' l' -> decompose_app_rec t l = decompose_app_rec t' l'. @@ -946,7 +946,7 @@ Qed. Lemma nth_error_map_InP {A B : Type} {P : A -> Type} (f : forall x : A, P x -> B) (l : list A) (H : forall x, In x l -> P x) n x : nth_error (map_InP f l H) n = Some x -> - ∑ a, (nth_error l n = Some a) * + ∑ a, (nth_error l n = Some a) * ∑ p : P a, x = f a p. Proof. induction l in n, H |- *. simpl. rewrite nth_error_nil => //. @@ -1016,7 +1016,7 @@ Inductive view_prod_sort : term -> Type := ~isSort t -> view_prod_sort t. -Equations view_prod_sortc (t : term) : view_prod_sort t := { +Equations view_prod_sortc (t : term) : view_prod_sort t := { | tProd na A B => view_prod_sort_prod na A B; | tSort u => view_prod_sort_sort u; | t => view_prod_sort_other t _ _ @@ -1024,7 +1024,7 @@ Equations view_prod_sortc (t : term) : view_prod_sort t := { -Lemma nth_error_ass_subst_context s k Γ : +Lemma nth_error_ass_subst_context s k Γ : (forall n d, nth_error Γ n = Some d -> decl_body d = None) -> forall n d, nth_error (subst_context s k Γ) n = Some d -> decl_body d = None. Proof. @@ -1038,7 +1038,7 @@ Proof. now specialize (H (S n0) d0 H1). Qed. -Lemma nth_error_smash_context Γ Δ : +Lemma nth_error_smash_context Γ Δ : (forall n d, nth_error Δ n = Some d -> decl_body d = None) -> forall n d, nth_error (smash_context Δ Γ) n = Some d -> decl_body d = None. Proof. @@ -1058,14 +1058,14 @@ Qed. Lemma context_assumptions_smash_context Δ Γ : - context_assumptions (smash_context Δ Γ) = + context_assumptions (smash_context Δ Γ) = context_assumptions Δ + context_assumptions Γ. Proof. induction Γ as [|[? [] ?] ?] in Δ |- *; simpl; auto; rewrite IHΓ. - now rewrite context_assumptions_fold. - rewrite context_assumptions_app /=. lia. -Qed. +Qed. Lemma context_assumptions_expand_lets_ctx Γ Δ : context_assumptions (expand_lets_ctx Γ Δ) = context_assumptions Δ. diff --git a/pcuic/theories/utils/PCUICOnOne.v b/pcuic/theories/utils/PCUICOnOne.v index 37f8d9c1d..301337ccc 100644 --- a/pcuic/theories/utils/PCUICOnOne.v +++ b/pcuic/theories/utils/PCUICOnOne.v @@ -23,7 +23,7 @@ Proof. + constructor. eassumption. + clear - IHh. rename IHh into h. induction h. - * constructor. + * constructor. * econstructor. -- econstructor 2. eassumption. -- assumption. @@ -47,17 +47,17 @@ Definition set_pcontext (p : predicate term) (pctx' : context) : predicate term pcontext := pctx'; preturn := p.(preturn) |}. -Definition set_pcontext_two {p x} x' : - set_pcontext (set_pcontext p x') x = set_pcontext p x := +Definition set_pcontext_two {p x} x' : + set_pcontext (set_pcontext p x') x = set_pcontext p x := eq_refl. - + Definition set_preturn (p : predicate term) (pret' : term) : predicate term := {| pparams := p.(pparams); puinst := p.(puinst); pcontext := p.(pcontext); preturn := pret' |}. -Definition set_preturn_two {p} pret pret' : set_preturn (set_preturn p pret') pret = set_preturn p pret := +Definition set_preturn_two {p} pret pret' : set_preturn (set_preturn p pret') pret = set_preturn p pret := eq_refl. Definition set_pparams (p : predicate term) (pars' : list term) : predicate term := @@ -66,7 +66,7 @@ Definition set_pparams (p : predicate term) (pars' : list term) : predicate term pcontext := p.(pcontext); preturn := p.(preturn) |}. -Definition set_pparams_two {p pars} pars' : set_pparams (set_pparams p pars') pars = set_pparams p pars := +Definition set_pparams_two {p pars} pars' : set_pparams (set_pparams p pars') pars = set_pparams p pars := eq_refl. Definition map_decl_na (f : aname -> aname) (g : term -> term) d := @@ -74,7 +74,7 @@ Definition map_decl_na (f : aname -> aname) (g : term -> term) d := decl_body := option_map g (decl_body d); decl_type := g (decl_type d) |}. -(** We do not allow alpha-conversion and P applies to only one of the +(** We do not allow alpha-conversion and P applies to only one of the fields in the context declaration. Used to define one-step context reduction. *) Definition on_one_decl (P : context -> term -> term -> Type) Γ (d : context_decl) (d' : context_decl) : Type := @@ -84,13 +84,13 @@ Definition on_one_decl (P : context -> term -> term -> Type) na = na' × P Γ ty ty' | {| decl_name := na; decl_body := Some b; decl_type := ty |}, {| decl_name := na'; decl_body := Some b'; decl_type := ty' |} => - na = na' × + na = na' × ((P Γ ty ty' × b = b') + (P Γ b b' × ty = ty')) | _, _ => False end. -Lemma on_one_decl_impl (P Q : context -> term -> term -> Type) : +Lemma on_one_decl_impl (P Q : context -> term -> term -> Type) : (forall Γ, inclusion (P Γ) (Q Γ)) -> forall Γ, inclusion (on_one_decl P Γ) (on_one_decl Q Γ). Proof. @@ -98,7 +98,7 @@ Proof. destruct x as [na [b|] ty], y as [na' [b'|] ty']; simpl; firstorder auto. Qed. -Lemma on_one_decl_map_na (P : context -> term -> term -> Type) f g : +Lemma on_one_decl_map_na (P : context -> term -> term -> Type) f g : forall Γ, inclusion (on_one_decl (fun Γ => on_Trel (P (map (map_decl_na f g) Γ)) g) Γ) (on_Trel (on_one_decl P (map (map_decl_na f g) Γ)) (map_decl_na f g)). @@ -108,7 +108,7 @@ Proof. auto. Qed. -Lemma on_one_decl_map (P : context -> term -> term -> Type) f : +Lemma on_one_decl_map (P : context -> term -> term -> Type) f : forall Γ, inclusion (on_one_decl (fun Γ => on_Trel (P (map (map_decl f) Γ)) f) Γ) (on_Trel (on_one_decl P (map (map_decl f) Γ)) (map_decl f)). @@ -118,7 +118,7 @@ Proof. auto. Qed. -Lemma on_one_decl_mapi_context (P : context -> term -> term -> Type) f : +Lemma on_one_decl_mapi_context (P : context -> term -> term -> Type) f : forall Γ, inclusion (on_one_decl (fun Γ => on_Trel (P (mapi_context f Γ)) (f #|Γ|)) Γ) (on_Trel (on_one_decl P (mapi_context f Γ)) (map_decl (f #|Γ|))). @@ -128,8 +128,8 @@ Proof. auto. Qed. -Lemma on_one_decl_test_impl (P Q : context -> term -> term -> Type) (p : term -> bool) : - forall Γ d d', +Lemma on_one_decl_test_impl (P Q : context -> term -> term -> Type) (p : term -> bool) : + forall Γ d d', on_one_decl P Γ d d' -> test_decl p d -> (forall x y, p x -> P Γ x y -> Q Γ x y) -> @@ -154,7 +154,7 @@ Section OnOne_local_2. End OnOne_local_2. #[global] -Instance OnOne2_local_env_length {P ctx ctx'} : +Instance OnOne2_local_env_length {P ctx ctx'} : HasLen (OnOne2_local_env P ctx ctx') #|ctx| #|ctx'|. Proof. induction 1; simpl; lia. @@ -169,7 +169,7 @@ Proof. induction H'; try solve [econstructor; firstorder]. Qed. -Lemma OnOne2_local_env_ondecl_impl P Q : +Lemma OnOne2_local_env_ondecl_impl P Q : (forall Γ, inclusion (P Γ) (Q Γ)) -> inclusion (OnOne2_local_env (on_one_decl P)) (OnOne2_local_env (on_one_decl P)). Proof. @@ -209,10 +209,10 @@ Proof. eapply test_decl_impl; tea; eauto. Qed. -Lemma OnOne2_local_env_test_context_k {P ctx ctx'} {k} {p q : nat -> term -> bool} : +Lemma OnOne2_local_env_test_context_k {P ctx ctx'} {k} {p q : nat -> term -> bool} : (forall n t, q n t -> p n t) -> OnOne2_local_env P ctx ctx' -> - (forall Γ d d', + (forall Γ d d', P Γ d d' -> test_context_k q k Γ -> test_decl (q (#|Γ| + k)) d -> @@ -250,9 +250,9 @@ Proof. subst; simpl; intuition eauto. Qed. -Lemma OnOne2_local_env_impl_test {P Q ctx ctx'} {k} {p : nat -> term -> bool} : +Lemma OnOne2_local_env_impl_test {P Q ctx ctx'} {k} {p : nat -> term -> bool} : OnOne2_local_env P ctx ctx' -> - (forall Γ d d', + (forall Γ d d', P Γ d d' -> test_context_k p k Γ -> test_decl (p (#|Γ| + k)) d -> diff --git a/pcuic/theories/utils/PCUICPretty.v b/pcuic/theories/utils/PCUICPretty.v index 0ca19b5d2..dccec1eba 100644 --- a/pcuic/theories/utils/PCUICPretty.v +++ b/pcuic/theories/utils/PCUICPretty.v @@ -67,8 +67,8 @@ Section fresh. Definition fresh_name (Γ : list ident) (na : name) (t : option term) : ident := let id := match na with | nNamed id => id - | nAnon => - match t with + | nAnon => + match t with | Some t => name_from_term t | None => "_" end @@ -81,7 +81,7 @@ Section fresh. {| decl_name := na; decl_type := decl_type decl; decl_body := decl_body decl |}. - + (* Definition build_return_context (ind : inductive) (oib : one_inductive_body) @@ -99,7 +99,7 @@ Section fresh. vass ind_binder_name (mkApps (tInd ind (puinst pred)) (pparams pred))) | None => None end. *) - + Definition fresh_names (Γ : list ident) (Γ' : context) : list ident := let fix aux Γids Γ := match Γ with @@ -138,7 +138,7 @@ Module PrintTermTree. Definition pr_context_decl Γ (c : context_decl) : ident * t := match c with - | {| decl_name := na; decl_type := ty; decl_body := None |} => + | {| decl_name := na; decl_type := ty; decl_body := None |} => let na' := (fresh_name Σ Γ na.(binder_name) (Some ty)) in (na', ("(" ^ na' ^ " : " ^ print_term Γ true false ty ^ ")")%bs) | {| decl_name := na; decl_type := ty; decl_body := Some b |} => @@ -146,11 +146,11 @@ Module PrintTermTree. (na', ("(" ^ na' ^ " : " ^ print_term Γ true false ty ^ " := " ^ print_term Γ true false b ^ ")")%bs) end. - + Fixpoint print_context_gen Γ Δ := match Δ with | [] => (Γ, "" : t) - | d :: decls => + | d :: decls => let '(Γ, s) := print_context_gen Γ decls in let '(na, s') := pr_context_decl Γ d in match decls with @@ -158,11 +158,11 @@ Module PrintTermTree. | _ => (na :: Γ, s ^ " " ^ s') end end. - + Fixpoint print_context_names Γ Δ := match Δ with | [] => (Γ, "" : t) - | d :: decls => + | d :: decls => let '(Γ, s) := print_context_names Γ decls in let na := (fresh_name Σ Γ d.(decl_name).(binder_name) (Some d.(decl_type))) in match decls with @@ -172,7 +172,7 @@ Module PrintTermTree. end. End Aux. - + Context (all : bool). Fixpoint print_term (Γ : list ident) (top : bool)(inapp : bool) (t : term) {struct t} : Tree.t := @@ -231,14 +231,14 @@ Module PrintTermTree. let in_args := (repeat "_" #|pparams p| ++ indices)%list in let in_str := oib.(ind_name) ^ concat "" (map (fun a : String.t => " " ^ a) in_args) in - let brs := map (fun br => - let (Γctx, pctx) := - if all then print_context_gen print_term Γ br.(bcontext) + let brs := map (fun br => + let (Γctx, pctx) := + if all then print_context_gen print_term Γ br.(bcontext) else print_context_names Γ br.(bcontext) in pctx ^ " ⇒ " ^ print_term Γctx true false br.(bbody)) brs in let brs := combine brs oib.(ind_ctors) in - + parens top ("match " ^ print_term Γ true false t ^ " as " ^ as_name ^ " in " ^ in_str ^ @@ -248,7 +248,7 @@ Module PrintTermTree. (nl ^ " | ") brs ^ nl ^ "end" ^ nl) | None => "Case(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_term t ^ "," - ^ string_of_predicate string_of_term p ^ "," ^ + ^ string_of_predicate string_of_term p ^ "," ^ string_of_list (pretty_string_of_branch string_of_term) brs ^ ")" end | tProj p c => @@ -282,7 +282,7 @@ Module PrintTermTree. Definition print_one_cstr Γ (mib : mutual_inductive_body) (c : constructor_body) : t := let '(Γargs, s) := print_context Γ c.(cstr_args) in c.(cstr_name) ^ " : " ^ s ^ "_" ^ print_list (pr_term Γargs true) " " c.(cstr_indices). - + Definition print_one_ind (short : bool) Γ (mib : mutual_inductive_body) (oib : one_inductive_body) : t := let '(Γpars, spars) := print_context Γ mib.(ind_params) in let '(Γinds, sinds) := print_context Γpars oib.(ind_indices) in @@ -298,28 +298,28 @@ Module PrintTermTree. | BiFinite => "Variant" end. - Fixpoint print_env_aux (short : bool) (prefix : nat) (Σ : global_env) (acc : t) : t := - match prefix with + Fixpoint print_env_aux (short : bool) (prefix : nat) (Σ : global_env) (acc : t) : t := + match prefix with | 0 => match Σ.(declarations) with [] => acc | _ => ("..." ^ nl ^ acc) end - | S n => + | S n => match Σ.(declarations) with | [] => acc - | (kn, InductiveDecl mib) :: decls => + | (kn, InductiveDecl mib) :: decls => let Σ' := (set_declarations Σ decls, mib.(ind_universes)) in let names := fresh_names Σ' [] (arities_context mib.(ind_bodies)) in print_env_aux short n Σ'.1 (print_recursivity_kind mib.(ind_finite) ^ " " ^ - print_list (print_one_ind Σ' short names mib) (nl ^ "with ") mib.(ind_bodies) ^ "." ^ + print_list (print_one_ind Σ' short names mib) (nl ^ "with ") mib.(ind_bodies) ^ "." ^ nl ^ acc) | (kn, ConstantDecl cb) :: decls => let Σ' := (set_declarations Σ decls, cb.(cst_universes)) in print_env_aux short n Σ'.1 - ((match cb.(cst_body) with + ((match cb.(cst_body) with | Some _ => "Definition " | None => "Axiom " end) ^ string_of_kername kn ^ " : " ^ print_term Σ' true nil true false cb.(cst_type) ^ match cb.(cst_body) with - | Some b => + | Some b => if short then ("..." ^ nl) else (" := " ^ nl ^ print_term Σ' true nil true false b ^ "." ^ nl) | None => "." @@ -327,22 +327,22 @@ Module PrintTermTree. end end. - Definition print_env (short : bool) (prefix : nat) Σ := + Definition print_env (short : bool) (prefix : nat) Σ := print_env_aux short prefix Σ (Tree.string ""). - Definition print_program (short : bool) (prefix : nat) (p : program) : t := - print_env short prefix (fst p) ^ nl ^ print_term (empty_ext (fst p)) true nil true false (snd p). + Definition print_program (short : bool) (prefix : nat) (p : program) : t := + print_env short prefix (fst p) ^ nl ^ print_term (empty_ext (fst p)) true nil true false (snd p). -End PrintTermTree. +End PrintTermTree. -Definition print_term Σ all Γ top inapp t := +Definition print_term Σ all Γ top inapp t := Tree.to_string (PrintTermTree.print_term Σ all Γ top inapp t). -Definition print_context Σ Γ Δ : string := +Definition print_context Σ Γ Δ : string := Tree.to_string (PrintTermTree.print_context_gen Σ (PrintTermTree.print_term Σ true) Γ Δ).2. -Definition print_env (short : bool) (prefix : nat) Σ := +Definition print_env (short : bool) (prefix : nat) Σ := Tree.to_string (PrintTermTree.print_env short prefix Σ). - -Definition print_program (short : bool) (prefix : nat) (p : program) : string := + +Definition print_program (short : bool) (prefix : nat) (p : program) : string := Tree.to_string (PrintTermTree.print_program short prefix p). \ No newline at end of file diff --git a/pcuic/theories/utils/PCUICPrimitive.v b/pcuic/theories/utils/PCUICPrimitive.v index c1918cee9..9d7cb25ca 100644 --- a/pcuic/theories/utils/PCUICPrimitive.v +++ b/pcuic/theories/utils/PCUICPrimitive.v @@ -29,7 +29,7 @@ Arguments primFloatModel {term}. Derive Signature NoConfusion for prim_model. -Definition prim_model_of (term : Type) (p : prim_tag) : Type := +Definition prim_model_of (term : Type) (p : prim_tag) : Type := match p with | primInt => PrimInt63.int | primFloat => PrimFloat.float @@ -59,7 +59,7 @@ Instance reflect_eq_Z : ReflectEq Z := EqDec_ReflectEq _. Local Obligation Tactic := idtac. #[program] #[global] -Instance reflect_eq_uint63 : ReflectEq uint63_model := +Instance reflect_eq_uint63 : ReflectEq uint63_model := { eqb x y := Z.eqb (proj1_sig x) (proj1_sig y) }. Next Obligation. cbn -[eqb]. @@ -77,9 +77,9 @@ Equations eqb_prim_model {term} {t : prim_tag} (x y : prim_model term t) : bool | primFloatModel x, primFloatModel y := ReflectEq.eqb x y. #[global, program] -Instance prim_model_reflecteq {term} {p : prim_tag} : ReflectEq (prim_model term p) := +Instance prim_model_reflecteq {term} {p : prim_tag} : ReflectEq (prim_model term p) := {| ReflectEq.eqb := eqb_prim_model |}. -Next Obligation. +Next Obligation. intros. depelim x; depelim y; simp eqb_prim_model. case: ReflectEq.eqb_spec; constructor; subst; auto. congruence. case: ReflectEq.eqb_spec; constructor; subst; auto. congruence. @@ -87,16 +87,16 @@ Qed. #[global] Instance prim_model_eqdec {term} : forall p : prim_tag, EqDec (prim_model term p) := _. - + Equations eqb_prim_val {term} (x y : prim_val term) : bool := | (primInt; i), (primInt; i') := ReflectEq.eqb i i' | (primFloat; f), (primFloat; f') := ReflectEq.eqb f f' | x, y := false. #[global, program] -Instance prim_val_reflect_eq {term} : ReflectEq (prim_val term) := +Instance prim_val_reflect_eq {term} : ReflectEq (prim_val term) := {| ReflectEq.eqb := eqb_prim_val |}. -Next Obligation. +Next Obligation. intros. funelim (eqb_prim_val x y); simp eqb_prim_val. case: ReflectEq.eqb_spec; constructor; subst; auto. intros H; noconf H. cbn in n. auto. constructor. intros H; noconf H; auto. diff --git a/pcuic/theories/utils/PCUICSize.v b/pcuic/theories/utils/PCUICSize.v index c0a178f2a..6843fd6df 100644 --- a/pcuic/theories/utils/PCUICSize.v +++ b/pcuic/theories/utils/PCUICSize.v @@ -5,7 +5,7 @@ From Coq Require Import ssreflect. Definition def_size (size : term -> nat) (x : def term) := size (dtype x) + size (dbody x). - + Definition mfixpoint_size (size : term -> nat) (l : mfixpoint term) := list_size (def_size size) l. @@ -14,12 +14,12 @@ Definition decl_size (size : term -> nat) (x : context_decl) := Definition context_size (size : term -> nat) (l : context) := list_size (decl_size size) l. - -Definition branch_size (size : term -> nat) (br : branch term) := + +Definition branch_size (size : term -> nat) (br : branch term) := context_size size br.(bcontext) + size br.(bbody). -Definition predicate_size (size : term -> nat) (p : PCUICAst.predicate term) := - list_size size p.(pparams) + +Definition predicate_size (size : term -> nat) (p : PCUICAst.predicate term) := + list_size size p.(pparams) + context_size size p.(pcontext) + size p.(preturn). @@ -45,9 +45,9 @@ Proof. rewrite IHl. simpl. lia. Qed. -Lemma nth_error_size {A} (f : A -> nat) {l : list A} {n x} : +Lemma nth_error_size {A} (f : A -> nat) {l : list A} {n x} : nth_error l n = Some x -> - f x < list_size f l. + f x < list_size f l. Proof. induction l in n |- *; destruct n; simpl => //; auto. - intros [= <-]. lia. diff --git a/safechecker/theories/Extraction.v b/safechecker/theories/Extraction.v index c8ab01b56..654115f47 100644 --- a/safechecker/theories/Extraction.v +++ b/safechecker/theories/Extraction.v @@ -1,6 +1,6 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import OrdersTac Ascii ExtrOcamlBasic ExtrOCamlInt63 ExtrOCamlFloats. -From MetaCoq.Template Require Import utils. +From MetaCoq.Template Require Import utils. From MetaCoq.SafeChecker Require Import PCUICSafeChecker PCUICSafeConversion SafeTemplateChecker. @@ -8,7 +8,7 @@ From MetaCoq.SafeChecker Require Import PCUICSafeChecker PCUICSafeConversion Any extracted code planning to link with the plugin's OCaml reifier should use these same directives for consistency. -*) +*) (** Here we could extract uint63_from/to_model to the identity *) @@ -39,13 +39,13 @@ Axiom fake_abstract_guard_impl_properties: PCUICTyping.guard fix_cofix Σ Γ mfix <-> PCUICWfEnvImpl.fake_guard_impl fix_cofix Σ Γ mfix. -#[local,program] Instance fake_abstract_guard_impl : PCUICWfEnvImpl.abstract_guard_impl := +#[local,program] Instance fake_abstract_guard_impl : PCUICWfEnvImpl.abstract_guard_impl := { guard_impl := PCUICWfEnvImpl.fake_guard_impl }. Next Obligation. eapply fake_abstract_guard_impl_properties. Qed. -Definition infer_and_print_template_program_with_guard {cf} {nor} := +Definition infer_and_print_template_program_with_guard {cf} {nor} := @SafeTemplateChecker.infer_and_print_template_program cf nor fake_abstract_guard_impl. Separate Extraction MakeOrderTac PCUICSafeChecker.typecheck_program diff --git a/safechecker/theories/PCUICConsistency.v b/safechecker/theories/PCUICConsistency.v index 08520b34f..e23a7cf2b 100644 --- a/safechecker/theories/PCUICConsistency.v +++ b/safechecker/theories/PCUICConsistency.v @@ -137,7 +137,7 @@ Proof. - split; first now intros ? ?%LevelSet.empty_spec. split; first now intros ? ?%ConstraintSet.empty_spec. destruct wfΣ as (?&(?&?&[val sat]&monoval)); split. - 1: { + 1: { exists val. intros l isin. apply sat; auto. diff --git a/safechecker/theories/PCUICEqualityDec.v b/safechecker/theories/PCUICEqualityDec.v index 8a674ab54..62c700a06 100644 --- a/safechecker/theories/PCUICEqualityDec.v +++ b/safechecker/theories/PCUICEqualityDec.v @@ -195,7 +195,7 @@ Local Ltac ih := repeat lazymatch goal with | ih : forall lequ Rle napp hle t' ht ht', reflectT (eq_term_upto_univ_napp _ _ _ napp ?t _) _, hle : forall u u' hu hu', reflect (?Rle u u') (?lequ u u') , - hcompare : forall R leq H ref n l l' _ _ , _ <-> _ + hcompare : forall R leq H ref n l l' _ _ , _ <-> _ |- context [ eqb_term_upto_univ _ ?lequ _ ?t ?t' ] => destruct (ih lequ Rle 0 hle t') ; nodec ; subst @@ -802,7 +802,7 @@ intros Hequ Heqlu Hcompare Hgen_compare Ht Hu. apply eq_true_iff_eq. split; intr * eapply reflect_eq_term_upto_univ; intros. 1-2: apply idP. + apply reflect_iff. rewrite <- Hgen_compare, <- Hcompare. - eapply reflect_R_global_instance with (p := wf_universeb Σ); eauto. + eapply reflect_R_global_instance with (p := wf_universeb Σ); eauto. 1: intros; rewrite <- Hequ; eauto. all: try apply idP. ++ revert H2. eapply reflect_iff; eapply wf_universe_reflect. ++ revert H3. eapply reflect_iff; eapply wf_universe_reflect. diff --git a/safechecker/theories/PCUICRetypingEnvIrrelevance.v b/safechecker/theories/PCUICRetypingEnvIrrelevance.v index 76387f054..0d6d8851c 100644 --- a/safechecker/theories/PCUICRetypingEnvIrrelevance.v +++ b/safechecker/theories/PCUICRetypingEnvIrrelevance.v @@ -10,27 +10,27 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICTypin PCUICWellScopedCumulativity PCUICSafeLemmata PCUICInversion. From MetaCoq.SafeChecker Require Import PCUICErrors PCUICSafeReduce PCUICWfEnv PCUICSafeRetyping. -(** We might need to weaken calls to the retyping function w.r.t. the global environment: i.e. - if we infer some type for a term in an environment Σ, then any other environment having at least +(** We might need to weaken calls to the retyping function w.r.t. the global environment: i.e. + if we infer some type for a term in an environment Σ, then any other environment having at least the same declarations as Σ should give us the same result. For example erasure can be called on all the declarations in a well-formed global environment without having to take successive prefixes of it. - + This does not follow from correctness of retyping alone. We rather prove that the result of retyping (and hence also reduction) are invariant in this sense. As retyping relies on reduction of types also show that safe reduction is invariant under extension. - This cannot be shown using only the correctness and completeness lemmas of reduction either as - in different enviroments we might find different declarations and hence produce different - reduced terms. Morally we could hope that a parametericity style lemma could prove this: - for two environments that are obsevationally equal on the declared constants/inductives - appearing in a well-typed terms, the output of reduction/inference is equal. + This cannot be shown using only the correctness and completeness lemmas of reduction either as + in different enviroments we might find different declarations and hence produce different + reduced terms. Morally we could hope that a parametericity style lemma could prove this: + for two environments that are obsevationally equal on the declared constants/inductives + appearing in a well-typed terms, the output of reduction/inference is equal. However parametricity would not directly allow us to restrict to observational equivalence only on declared constants, so we have to perform this relational proof meticulously. - As the functions involved use dependent types everywhere, we restrict our observations to the + As the functions involved use dependent types everywhere, we restrict our observations to the computational results returned by each function and do not compare proofs (in potentially different types/fibers). *) Implicit Types (cf : checker_flags). Definition Hlookup {cf} (X_type : abstract_env_impl) (X : X_type.π2.π1) (X_type' : abstract_env_impl) - (X' : X_type'.π2.π1) := + (X' : X_type'.π2.π1) := forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> (forall kn decl decl', @@ -63,24 +63,24 @@ Section infer_irrel. Context {cf} {nor : normalizing_flags} {X_type : abstract_env_impl} {X : X_type.π2.π1} {X_type' : abstract_env_impl} {X' : X_type'.π2.π1}. Context (hl : Hlookup X_type X X_type' X'). - + Definition same_prod (Γ : context) {T} (pf : ∑ (na' : aname) (A' B' : term), forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ Σ ;;; Γ ⊢ T ⇝ tProd na' A' B' ∥) (pf' : ∑ (na' : aname) (A' B' : term), forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> ∥ Σ ;;; Γ ⊢ T ⇝ tProd na' A' B' ∥) := let '(na; A; B; _) := pf in let '(na'; A'; B'; _) := pf' in (na, A, B) = (na', A', B'). - + Lemma same_prod_last (Γ : context) {T} (pf : ∑ (na' : aname) (A' B' : term), forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ Σ ;;; Γ ⊢ T ⇝ tProd na' A' B' ∥) - (pf' : ∑ (na' : aname) (A' B' : term), forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> ∥ Σ ;;; Γ ⊢ T ⇝ tProd na' A' B' ∥) + (pf' : ∑ (na' : aname) (A' B' : term), forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> ∥ Σ ;;; Γ ⊢ T ⇝ tProd na' A' B' ∥) : same_prod Γ pf pf' -> pf.π2.π2.π1 = pf'.π2.π2.π1. Proof using Type. destruct pf as [na [A [B prf]]]. destruct pf' as [na' [A' []]]. cbn. congruence. Qed. - + Lemma same_reduce_stack {Γ t π} {fl} (wi : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ (PCUICPosition.zip (t, π))) (wi' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ (PCUICPosition.zip (t, π))) : reduce_stack fl X_type X Γ t π wi = reduce_stack fl X_type' X' Γ t π wi'. @@ -107,7 +107,7 @@ Section infer_irrel. [ |- context [rec ?t ?π ?hr] ] => match goal with [ |- context [rec' ?t' ?π' ?hr'] ] => - let H := fresh in + let H := fresh in assert (H := ih t π hr hr'); set (call := rec t π hr) in *; set (call' := rec' t π' hr') in *; @@ -179,7 +179,7 @@ Section infer_irrel. [ |- context [rec ?t ?π ?hr] ] => match goal with [ |- context [rec' ?t' ?π' ?hr'] ] => - let H := fresh in + let H := fresh in assert (H := ih t π hr hr'); set (call := rec t π hr) in *; set (call' := rec' t π' hr') in * @@ -205,7 +205,7 @@ Section infer_irrel. subst x0. destruct x. simp _reduce_stack. destruct (construct_viewc); simp _reduce_stack. - * destruct PCUICSafeReduce.inspect; simp _reduce_stack. + * destruct PCUICSafeReduce.inspect; simp _reduce_stack. destruct x as []; simp _reduce_stack. simpl. subst call call'. reccall ih rec rec'. @@ -232,7 +232,7 @@ Section infer_irrel. reccall ih rec rec'. congruence. } subst x0. destruct x. simp _reduce_stack. - destruct PCUICSafeReduce.inspect; simp _reduce_stack. + destruct PCUICSafeReduce.inspect; simp _reduce_stack. destruct x as []; simp _reduce_stack. destruct cc_viewc; simp _reduce_stack. 3:reflexivity. destruct PCUICSafeReduce.inspect; simp _reduce_stack. @@ -264,7 +264,7 @@ Section infer_irrel. reccall ih rec rec'. congruence. } subst x0. destruct x. simp _reduce_stack. - destruct PCUICSafeReduce.inspect; simp _reduce_stack. + destruct PCUICSafeReduce.inspect; simp _reduce_stack. destruct x as []; simp _reduce_stack. destruct cc0_viewc; simp _reduce_stack. 3:reflexivity. destruct PCUICSafeReduce.inspect; simp _reduce_stack. @@ -286,7 +286,7 @@ Section infer_irrel. f_equal. apply same_reduce_stack. Qed. - Definition same_typing_result_comp {A B} (P : A -> B -> Prop) (c : typing_result_comp A) (c' : typing_result_comp B) : Prop := + Definition same_typing_result_comp {A B} (P : A -> B -> Prop) (c : typing_result_comp A) (c' : typing_result_comp B) : Prop := match c, c' with | Checked_comp a, Checked_comp a' => P a a' | TypeError_comp e ne, TypeError_comp e' na' => True @@ -294,7 +294,7 @@ Section infer_irrel. end. Definition same_prod_comp {Γ T} - (pf : typing_result_comp (∑ (na' : aname) (A' B' : term), + (pf : typing_result_comp (∑ (na' : aname) (A' B' : term), forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ Σ ;;; Γ ⊢ T ⇝ tProd na' A' B' ∥)) (pf' : typing_result_comp (∑ (na' : aname) (A' B' : term), forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> ∥ Σ ;;; Γ ⊢ T ⇝ tProd na' A' B' ∥)) := @@ -302,7 +302,7 @@ Section infer_irrel. Lemma reduce_to_prod_irrel {Γ t} (wi : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) - (wi' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t) : + (wi' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t) : same_prod_comp (reduce_to_prod Γ t wi) (reduce_to_prod Γ t wi'). Proof using hl. unfold reduce_to_prod. @@ -320,12 +320,12 @@ Section infer_irrel. destruct v'. cbn. subst t0. now cbn in n0. subst t1. cbn. auto. Qed. - - Lemma infer_as_prod_irrel {Γ t} + + Lemma infer_as_prod_irrel {Γ t} (wf : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ wf_local Σ Γ ∥) (wf' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> ∥ wf_local Σ Γ ∥) (wi : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) - (wi' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t) + (wi' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t) hp hp' : same_prod Γ (infer_as_prod X_type X Γ t wf wi hp) (infer_as_prod X_type' X' Γ t wf' wi' hp'). Proof using hl. unfold same_prod. @@ -336,19 +336,19 @@ Section infer_irrel. rewrite h h' in H. now cbn in H. Qed. - Definition same_sort_comp {cf} {nor : normalizing_flags} + Definition same_sort_comp {cf} {nor : normalizing_flags} {X_type : abstract_env_impl} {X : X_type.π2.π1} {X_type' : abstract_env_impl} {X' : X_type'.π2.π1} {Γ : context} {t t'} (pf : typing_result_comp (∑ u, forall Σ0 : global_env_ext, abstract_env_ext_rel X Σ0 -> ∥ Σ0 ;;; Γ ⊢ t ⇝ tSort u ∥)) - (pf' : typing_result_comp + (pf' : typing_result_comp (∑ u, forall Σ0 : global_env_ext, abstract_env_ext_rel X' Σ0 -> ∥ Σ0 ;;; Γ ⊢ t' ⇝ tSort u ∥)) := same_typing_result_comp (fun x y => x.π1 = y.π1) pf pf'. Lemma reduce_to_sort_irrel {Γ t t'} (e : t = t') (wi : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) - (wi' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t') : + (wi' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t') : same_sort_comp (reduce_to_sort Γ t wi) (reduce_to_sort Γ t' wi'). Proof using hl. destruct e. @@ -370,11 +370,11 @@ Section infer_irrel. subst t1. cbn. auto. Qed. - Lemma infer_as_sort_irrel {Γ t} + Lemma infer_as_sort_irrel {Γ t} (wf : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ wf_local Σ Γ ∥) (wf' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> ∥ wf_local Σ Γ ∥) (wi : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> well_sorted Σ Γ t) - (wi' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> well_sorted Σ Γ t) + (wi' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> well_sorted Σ Γ t) hp hp' : hp.π1 = hp'.π1 -> (infer_as_sort X_type X wf wi hp).π1 = (infer_as_sort X_type' X' wf' wi' hp').π1. Proof using hl. unfold infer_as_sort. @@ -390,8 +390,8 @@ Section infer_irrel. rewrite h h' in H. now cbn in H. Qed. - Definition same_ind_comp {Γ t t'} - (pf : typing_result_comp + Definition same_ind_comp {Γ t t'} + (pf : typing_result_comp (∑ (i : inductive) (u : Instance.t) (l : list term), forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> @@ -401,7 +401,7 @@ Section infer_irrel. forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> ∥ Σ ;;; Γ ⊢ t' ⇝ mkApps (tInd i u) l ∥)) := same_typing_result_comp (fun x y => (x.π1, x.π2.π1, x.π2.π2.π1) = (y.π1, y.π2.π1, y.π2.π2.π1)) pf pf'. - + Lemma elim_inspect {A} (x : A) (P : { y : A | y = x } -> Type) : (forall y (e : y = x), P (exist y e)) -> P (PCUICSafeReduce.inspect x). @@ -411,7 +411,7 @@ Section infer_irrel. Lemma reduce_to_ind_irrel {Γ t t'} (e : t = t') (wi : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) - (wi' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t') : + (wi' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> welltyped Σ Γ t') : same_ind_comp (reduce_to_ind Γ t wi) (reduce_to_ind Γ t' wi'). Proof using hl. subst t'. @@ -428,17 +428,17 @@ Section infer_irrel. eapply elim_inspect => [[app st] eqst]. simp reduce_to_ind => //. Qed. - Definition same_typing_result {A B} (P : A -> B -> Prop) (c : typing_result A) (c' : typing_result B) : Prop := + Definition same_typing_result {A B} (P : A -> B -> Prop) (c : typing_result A) (c' : typing_result B) : Prop := match c, c' with | Checked a, Checked a' => P a a' | TypeError e, TypeError e' => True | _, _ => False end. - + Lemma same_lookup_ind_decl ind : abstract_env_lookup X (inductive_mind ind) = abstract_env_lookup X' (inductive_mind ind) -> same_typing_result (fun x y => (x.π1, x.π2.π1) = (y.π1, y.π2.π1)) (lookup_ind_decl X_type X ind) (lookup_ind_decl X_type' X' ind). - Proof using Type. + Proof using Type. intros eq. funelim (lookup_ind_decl X_type X ind); simp lookup_ind_decl; eapply elim_inspect; intros opt e'. @@ -453,7 +453,7 @@ Section infer_irrel. - destruct opt as [[]|] => //. simp lookup_ind_decl. eapply elim_inspect; intros opt e''. destruct opt => //. simp lookup_ind_decl. cbn. congruence. - Qed. + Qed. End infer_irrel. @@ -524,7 +524,7 @@ Proof. pose proof (hd _ wfΣ). destruct isdecl, H0. unfold declared_minductive in *. - now eapply (hl Σ wfΣ Σ' wfΣ'). } + now eapply (hl Σ wfΣ Σ' wfΣ'). } destruct (PCUICSafeReduce.inspect (lookup_ind_decl _ X' ind)). generalize (same_lookup_ind_decl ind H). rewrite -{1}e0 -{1}e. destruct x => //. cbn. cbn. @@ -542,7 +542,7 @@ Proof. destruct isdecl, H0. inv X0. destruct H1. destruct isdecl as [[] ?]. unfold declared_minductive in *. - now eapply (hl Σ wfΣ Σ' wfΣ'). } + now eapply (hl Σ wfΣ Σ' wfΣ'). } destruct (PCUICSafeReduce.inspect (lookup_ind_decl _ X' ind)). generalize (same_lookup_ind_decl _ H). rewrite -{1}e1 -{1}e. destruct x => //. @@ -584,7 +584,7 @@ Proof. pose proof (wt _ wfΣ). inv H1. inv X0. destruct H1 as [[[]]]. destruct H as [[[]]]. unfold declared_minductive in *. - now eapply (hl Σ wfΣ Σ' wfΣ'). } + now eapply (hl Σ wfΣ Σ' wfΣ'). } generalize (same_lookup_ind_decl _ H). rewrite -{1}eq -{1}e. destruct y => //. destruct a as [decl [body ?]], d as [decl' [body' ?]]. @@ -628,7 +628,7 @@ Lemma sort_of_type_irrel {cf} {nor : normalizing_flags} {X_type : abstract_env_impl} {X : X_type.π2.π1} {X_type' : abstract_env_impl} {X' : X_type'.π2.π1} (hl : Hlookup X_type X X_type' X') - {Γ : context} {t} + {Γ : context} {t} (wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ isType Σ Γ t ∥) (wt' : forall Σ : global_env_ext, abstract_env_ext_rel X' Σ -> ∥ isType Σ Γ t ∥) : (sort_of_type X_type X Γ t wt).π1 = (sort_of_type X_type' X' Γ t wt').π1. diff --git a/safechecker/theories/PCUICSafeChecker.v b/safechecker/theories/PCUICSafeChecker.v index 5377ee127..681418cd4 100644 --- a/safechecker/theories/PCUICSafeChecker.v +++ b/safechecker/theories/PCUICSafeChecker.v @@ -282,11 +282,11 @@ Section CheckEnv. (* Local Definition gX := abstract_env_rel Σ. *) - Local Definition heΣ X Σ (wfΣ : abstract_env_rel X Σ) : + Local Definition heΣ X Σ (wfΣ : abstract_env_rel X Σ) : ∥ wf Σ ∥ := abstract_env_wf _ wfΣ. Local Definition hΣ X_ext Σ (wfΣ : abstract_env_ext_rel X_ext Σ) : - ∥ wf Σ ∥ := abstract_env_ext_sq_wf _ _ _ wfΣ. + ∥ wf Σ ∥ := abstract_env_ext_sq_wf _ _ _ wfΣ. Definition check_wf_type (kn : kername) X_ext t : EnvCheck X_env_ext_type (forall Σ : global_env_ext, abstract_env_ext_rel X_ext Σ -> ∥ isType Σ [] t ∥) := @@ -312,13 +312,13 @@ Section CheckEnv. | false => ret _ end end. - Next Obligation. + Next Obligation. sq. constructor; tas. simpl. change (false = eqb id k) in Heq_anonymous. destruct (eqb_spec id k); [discriminate|]. easy. Qed. - + Section UniverseChecks. Obligation Tactic := idtac. @@ -375,7 +375,7 @@ Section CheckEnv. apply wf_global_uctx_invariants in HΣ. enough (satisfiable_udecl Σ udecl /\ valid_on_mono_udecl (global_uctx Σ) udecl). 1: case: H3; split=> //; apply: consistent_extension_on_global=> //. - + eapply abstract_env_is_consistent_uctx_correct; eauto=> //. split. * apply LevelSet.union_spec; right ; apply HΣ. @@ -401,23 +401,23 @@ Section CheckEnv. let X' := abstract_env_add_uctx X uctx.π1 ext _ _ in ret (exist X' _) end. - Next Obligation. + Next Obligation. simpl; intros. split; intros; try split. - - cbn. pose proof (abstract_env_wf _ H). sq. + - cbn. pose proof (abstract_env_wf _ H). sq. eapply abstract_env_empty_ext_rel; eauto. - - now apply abstract_env_empty_ext_rel in H. + - now apply abstract_env_empty_ext_rel in H. Qed. Next Obligation. simpl; cbn; intros. exact (proj1 uctx.π2). Qed. Next Obligation. simpl; cbn; intros. pose proof (abstract_env_exists X) as [[? ?]]. - erewrite <- abstract_env_univ_correct; eauto. eapply (proj2 uctx.π2); eauto. + erewrite <- abstract_env_univ_correct; eauto. eapply (proj2 uctx.π2); eauto. Qed. Next Obligation. simpl; cbn; intros. split; intros ? ?. { rewrite Heq_ext. - destruct uctx as [uctx' [gcof onu]]. cbn. + destruct uctx as [uctx' [gcof onu]]. cbn. eapply abstract_env_add_uctx_rel; cbn; eauto. } { eapply abstract_env_add_uctx_rel with (udecl := ext) in H; cbn; try now eauto. } Qed. @@ -432,7 +432,7 @@ Section CheckEnv. typing_result (∑ T, forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ Σ ;;; Γ |- t : T ∥) := infer_typing X_ext Γ wfΓ t := typing_error_forget (infer X_impl X_ext Γ wfΓ t) ;; ret _. Next Obligation. - exists y. intros. + exists y. intros. pose proof (hΣ _ _ H). specialize_Σ H. sq. cbn in *. now apply infering_typing. Qed. @@ -450,10 +450,10 @@ Section CheckEnv. '(y ; H) <- typing_error_forget (infer_type X_impl X_ext (infer X_impl X_ext) Γ wfΓ t) ;; ret (y ; _). Next Obligation. - intros. pose proof (abstract_env_ext_wf _ H0). specialize_Σ H0. - sq. now apply infering_sort_typing. + intros. pose proof (abstract_env_ext_wf _ H0). specialize_Σ H0. + sq. now apply infering_sort_typing. Qed. - + Definition check_context_wf_env X_ext (Γ : context) : typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ Γ ∥) := check_context X_impl X_ext (infer X_impl X_ext) Γ. @@ -498,7 +498,7 @@ Section CheckEnv. ret _ end. Next Obligation. - erewrite <- abstract_env_ext_wf_universeb_correct in Heq_anonymous; eauto. + erewrite <- abstract_env_ext_wf_universeb_correct in Heq_anonymous; eauto. now sq; apply/PCUICWfUniverses.wf_universe_reflect. Qed. Next Obligation. @@ -516,22 +516,22 @@ Section CheckEnv. split; auto. split; auto. eapply PCUICValidity.validity in checkty; auto. Qed. - + Program Fixpoint infer_sorts_local_ctx X_ext Γ Δ (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ Γ ∥) : typing_result (∑ s, forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ sorts_local_ctx (lift_typing typing) Σ Γ Δ s ∥) := match Δ with | [] => ret ([]; fun _ _ => sq _) - | {| decl_body := None; decl_type := ty |} :: Δ => + | {| decl_body := None; decl_type := ty |} :: Δ => '(Δs; Δinfer) <- infer_sorts_local_ctx X_ext Γ Δ wfΓ ;; '(tys; tyinfer) <- infer_type_wf_env X_ext (Γ ,,, Δ) _ ty ;; ret ((tys :: Δs); _) - | {| decl_body := Some b; decl_type := ty |} :: Δ => + | {| decl_body := Some b; decl_type := ty |} :: Δ => '(Δs; Δinfer) <- infer_sorts_local_ctx X_ext Γ Δ wfΓ ;; checkty <- check_type_wf_env X_ext (Γ ,,, Δ) _ b ty ;; ret (Δs; _) end. - Next Obligation. exact tt. Qed. - Next Obligation. + Next Obligation. exact tt. Qed. + Next Obligation. specialize_Σ H. sq. now eapply PCUICContexts.sorts_local_ctx_wf_local in Δinfer. Qed. Next Obligation. @@ -556,15 +556,15 @@ Section CheckEnv. Program Definition wf_env_check_cumul_decl X_ext le Γ d d' := check_ws_cumul_pb_decl X_impl X_ext le Γ d d'. - Program Fixpoint wf_env_check_ws_cumul_ctx (le : conv_pb) X_ext Γ Δ Δ' + Program Fixpoint wf_env_check_ws_cumul_ctx (le : conv_pb) X_ext Γ Δ Δ' (wfΔ : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ (Γ ,,, Δ) ∥) (wfΔ' : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ (Γ ,,, Δ') ∥) : typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ ws_cumul_ctx_pb_rel le Σ Γ Δ Δ' ∥) := check_ws_cumul_ctx X_impl X_ext le Γ Δ Δ' wfΔ wfΔ'. Notation eqb_term_conv X conv_pb := (eqb_term_upto_univ (abstract_env_eq X) (abstract_env_conv_pb_relb X conv_pb) (abstract_env_compare_global_instance X)). - - Program Definition check_eq_term pb X_ext t u + + Program Definition check_eq_term pb X_ext t u (wft : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_universes Σ t) (wfu : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_universes Σ u) : typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ compare_term pb Σ Σ t u ∥) := @@ -576,26 +576,26 @@ Section CheckEnv. (* destruct X as [X M HM [wfΣ] G wfG]; simpl in *. sq. *) simpl in *; sq. eapply eqb_term_upto_univ_impl in check; sq; eauto. - - intros u0 u'. repeat erewrite <- abstract_env_ext_wf_universeb_correct; eauto. - move => / wf_universe_reflect ? => /wf_universe_reflect ?. + - intros u0 u'. repeat erewrite <- abstract_env_ext_wf_universeb_correct; eauto. + move => / wf_universe_reflect ? => /wf_universe_reflect ?. apply iff_reflect. eapply (abstract_env_compare_universe_correct _ _ Conv); eauto. - - intros u0 u'. repeat erewrite <- abstract_env_ext_wf_universeb_correct; eauto. - move => /wf_universe_reflect ? => /wf_universe_reflect ?. + - intros u0 u'. repeat erewrite <- abstract_env_ext_wf_universeb_correct; eauto. + move => /wf_universe_reflect ? => /wf_universe_reflect ?. apply iff_reflect. eapply (abstract_env_compare_universe_correct _ _ pb); eauto. - intros. apply abstract_env_compare_global_instance_correct; eauto. + move => ? ? /wf_universe_reflect ? => /wf_universe_reflect ?. apply X;eauto. (* erewrite <- abstract_env_ext_wf_universeb_correct; eauto. *) - + apply wf_universe_instance_iff. rewrite <- wf_universeb_instance_forall; eauto. + + apply wf_universe_instance_iff. rewrite <- wf_universeb_instance_forall; eauto. (* erewrite forallb_ext; eauto. intros ?; apply abstract_env_ext_wf_universeb_correct; eauto. *) - + apply wf_universe_instance_iff. rewrite <- wf_universeb_instance_forall; eauto. + + apply wf_universe_instance_iff. rewrite <- wf_universeb_instance_forall; eauto. (* erewrite forallb_ext; eauto. intros ?; apply abstract_env_ext_wf_universeb_correct; eauto. *) - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. - Program Definition check_eq_decl pb X_ext d d' + Program Definition check_eq_decl pb X_ext d d' (wfd : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_decl_universes Σ d) - (wfd' : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_decl_universes Σ d') : + (wfd' : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_decl_universes Σ d') : typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ compare_decl pb Σ Σ d d' ∥) := match d, d' return (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_decl_universes Σ d) -> (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_decl_universes Σ d') -> @@ -612,35 +612,35 @@ Section CheckEnv. cumt <- check_eq_term pb X_ext ty ty' _ _ ;; ret (fun Σ wfΣ => _) | _, _ => fun _ _ => raise (Msg "While checking syntactic cumulativity of contexts: declarations do not match") - end wfd wfd'. + end wfd wfd'. Next Obligation. - specialize_Σ H. now pose proof i as [? ?]%andb_and. - Qed. + specialize_Σ H. now pose proof i as [? ?]%andb_and. + Qed. Next Obligation. - specialize_Σ H. now pose proof i0 as [? ?]%andb_and. + specialize_Σ H. now pose proof i0 as [? ?]%andb_and. Qed. Next Obligation. - specialize_Σ H. now pose proof i as [? ?]%andb_and. + specialize_Σ H. now pose proof i as [? ?]%andb_and. Qed. Next Obligation. - specialize_Σ H. now pose proof i0 as [? ?]%andb_and. - Qed. + specialize_Σ H. now pose proof i0 as [? ?]%andb_and. + Qed. Next Obligation. - specialize_Σ wfΣ. sq. + specialize_Σ wfΣ. sq. eapply eqb_binder_annot_spec in eqna. constructor; auto. Qed. Next Obligation. - specialize_Σ wfΣ. sq. + specialize_Σ wfΣ. sq. eapply eqb_binder_annot_spec in eqna. constructor; auto. Qed. - Program Fixpoint check_compare_context (pb : conv_pb) X_ext Γ Δ + Program Fixpoint check_compare_context (pb : conv_pb) X_ext Γ Δ (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_ctx_universes Σ Γ) - (wfΔ : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_ctx_universes Σ Δ) : + (wfΔ : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_ctx_universes Σ Δ) : typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ PCUICEquality.compare_context pb Σ Σ Γ Δ ∥) := - match Γ, Δ return (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_ctx_universes Σ Γ) -> + match Γ, Δ return (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_ctx_universes Σ Γ) -> (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_ctx_universes Σ Δ) -> typing_result _ with | [], [] => fun _ _ => ret (fun Σ wfΣ => sq (All2_fold_nil _)) @@ -651,23 +651,23 @@ Section CheckEnv. | _, _ => fun _ _ => raise (Msg "While checking ws_cumul_pb of contexts: contexts do not have the same length") end wfΓ wfΔ. Next Obligation. - specialize_Σ H. now pose proof i as [? ?]%andb_and. + specialize_Σ H. now pose proof i as [? ?]%andb_and. Qed. Next Obligation. - specialize_Σ H. now pose proof i0 as [? ?]%andb_and. + specialize_Σ H. now pose proof i0 as [? ?]%andb_and. Qed. Next Obligation. - specialize_Σ H. now pose proof i as [? ?]%andb_and. + specialize_Σ H. now pose proof i as [? ?]%andb_and. Qed. Next Obligation. - specialize_Σ H. now pose proof i0 as [? ?]%andb_and. + specialize_Σ H. now pose proof i0 as [? ?]%andb_and. Qed. Next Obligation. specialize_Σ wfΣ. sq. constructor; auto. Qed. - Program Fixpoint check_leq_terms (pb : conv_pb) X_ext l l' + Program Fixpoint check_leq_terms (pb : conv_pb) X_ext l l' (wfl : forall Σ, abstract_env_ext_rel X_ext Σ -> forallb (wf_universes Σ) l) (wfl' : forall Σ, abstract_env_ext_rel X_ext Σ -> forallb (wf_universes Σ) l') : typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ All2 (compare_term pb Σ Σ) l l' ∥) := @@ -680,18 +680,18 @@ Section CheckEnv. ret (fun Σ wfΣ => _) | _, _ => fun _ _ => raise (Msg "While checking ws_cumul_pb of term lists: lists do not have the same length") end wfl wfl'. - Next Obligation. apply All2_nil. Qed. + Next Obligation. apply All2_nil. Qed. Next Obligation. - specialize_Σ H. now pose proof i as [? ?]%andb_and. + specialize_Σ H. now pose proof i as [? ?]%andb_and. Qed. Next Obligation. - specialize_Σ H. now pose proof i0 as [? ?]%andb_and. + specialize_Σ H. now pose proof i0 as [? ?]%andb_and. Qed. Next Obligation. - specialize_Σ H. now pose proof i as [? ?]%andb_and. + specialize_Σ H. now pose proof i as [? ?]%andb_and. Qed. Next Obligation. - specialize_Σ H. now pose proof i0 as [? ?]%andb_and. + specialize_Σ H. now pose proof i0 as [? ?]%andb_and. Qed. Next Obligation. specialize_Σ wfΣ. sq. constructor; auto. @@ -700,7 +700,7 @@ Section CheckEnv. Definition wt_terms Σ Γ l := Forall (welltyped Σ Γ) l. Program Fixpoint check_conv_args X_ext Γ (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ Γ ∥) l l' - (wfl : forall Σ, abstract_env_ext_rel X_ext Σ -> wt_terms Σ Γ l) + (wfl : forall Σ, abstract_env_ext_rel X_ext Σ -> wt_terms Σ Γ l) (wfl' : forall Σ, abstract_env_ext_rel X_ext Σ -> wt_terms Σ Γ l') : typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ ws_cumul_pb_terms Σ Γ l l' ∥) := match l, l' with @@ -860,7 +860,7 @@ Section CheckEnv. Next Obligation. pose proof (abstract_env_ext_wf _ H); specialize_Σ H; sq. apply wf_ind_types_wf_arities in wfar; eauto. - now eapply weaken_wf_local; eauto. + now eapply weaken_wf_local; eauto. Qed. Next Obligation. pose proof (abstract_env_ext_wf _ wfΣ); specialize_Σ wfΣ. @@ -893,7 +893,7 @@ Section CheckEnv. (a : All2 (fun x y => forall (aa:AA) (bb:BB aa), ∥ P aa bb x y ∥) l l') (aa:AA) (bb:BB aa) : ∥ All2 (P aa bb) l l' ∥ := match a with | All2_nil => sq All2_nil - | All2_cons _ _ _ _ rxy all' => + | All2_cons _ _ _ _ rxy all' => let 'sq all := All2_sq all' aa bb in let 'sq rxy := rxy aa bb in sq (All2_cons rxy all) @@ -906,7 +906,7 @@ Section CheckEnv. (cstrs : list constructor_body) : EnvCheck X_env_ext_type (∑ cs : list constructor_univs, forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ All2 (fun cstr cs => check_constructor_spec Σ ind mdecl cstr cs) cstrs cs ∥) := css <- monad_All (fun d => check_constructor X_ext ind mdecl wfar wfpars d) cstrs ;; - let '(cs; all2) := All_sigma css in + let '(cs; all2) := All_sigma css in ret (cs ; fun Σ wfΣ => All2_sq all2 Σ wfΣ). Lemma isType_it_mkProd_or_LetIn_inv {Σ : global_env_ext} Γ Δ T : @@ -1232,20 +1232,20 @@ Section CheckEnv. We could also intersperse weak-head normalizations to reduce the types. This would need to be done in sync with a change in the spec in EnvironmentTyping though. *) - Program Fixpoint check_positive_cstr_arg + Program Fixpoint check_positive_cstr_arg mdecl Γ t (wt : forall Σ, abstract_env_ext_rel X_ext Σ -> welltyped Σ Γ t) Δ {measure (Γ; t; wt) (@redp_subterm_rel cf _ X_ext)} : typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ positive_cstr_arg mdecl Δ t ∥) := if closedn #|Δ| t then ret _ else match prod_letin_viewc t in prod_letin_view t' with - | prod_letin_tProd na ty t => + | prod_letin_tProd na ty t => posarg <- check_eq_true (closedn #|Δ| ty) (Msg "Non-positive occurrence.");; post <- check_positive_cstr_arg mdecl (vass na ty :: Γ) t _ (vass na ty :: Δ) ;; ret _ - | prod_letin_tLetIn na b ty t => + | prod_letin_tLetIn na b ty t => post <- check_positive_cstr_arg mdecl Γ (subst0 [b] t) _ Δ ;; ret _ - | prod_letin_other t nprodlet => + | prod_letin_other t nprodlet => let '(hd, args) := decompose_app t in '(hdrel; eqr) <- isRel hd ;; isind <- check_eq_true ((#|Δ| <=? hdrel) && (hdrel welltyped Σ Γ t) Δ { measure (Γ; t; wt) (@redp_subterm_rel cf _ X_ext) } : typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ positive_cstr mdecl n Δ t ∥) := match prod_letin_viewc t in prod_letin_view t' with - | prod_letin_tProd na ty t => + | prod_letin_tProd na ty t => posarg <- check_positive_cstr_arg mdecl Γ ty _ Δ ;; post <- check_positive_cstr mdecl n (vass na ty :: Γ) t _ (vass na ty :: Δ) ;; ret _ - | prod_letin_tLetIn na b ty t => + | prod_letin_tLetIn na b ty t => (* Do reduction *) post <- check_positive_cstr mdecl n Γ (subst0 [b] t) _ Δ ;; ret _ - | prod_letin_other t Ht => + | prod_letin_other t Ht => let '(hd, indices) := decompose_app t in eqhd <- check_eq_true (eqb hd (tRel (#|ind_bodies mdecl| - S n + #|Δ|))) (Msg "Conclusion of constructor is not the right inductive type") ;; @@ -1391,12 +1391,12 @@ Section CheckEnv. ret _ end. Next Obligation. - pose proof (abstract_env_ext_wf _ H); specialize_Σ H. + pose proof (abstract_env_ext_wf _ H); specialize_Σ H. sq. constructor; eauto. eapply validity in wfty. apply wfty. Qed. Next Obligation. - pose proof (abstract_env_ext_wf _ H); specialize_Σ H. + pose proof (abstract_env_ext_wf _ H); specialize_Σ H. sq. constructor; auto. now exists wfty. Qed. @@ -1524,7 +1524,7 @@ Section CheckEnv. now eapply isType_welltyped in isTy. Qed. - Lemma get_wt_indices {mdecl cstrs cs} X_ext + Lemma get_wt_indices {mdecl cstrs cs} X_ext (wfar : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_ind_types Σ mdecl ∥) (wfpars : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ (ind_params mdecl) ∥) (n : nat) (idecl : one_inductive_body) (indices : context) @@ -1535,7 +1535,7 @@ Section CheckEnv. check_constructor_spec Σ (S n) mdecl cstr cs0) cstrs cs ∥) -> forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ All (fun cs => wt_indices Σ mdecl indices cs) cstrs ∥. Proof using Type. - intros. pose proof (abstract_env_ext_wf _ H0) as wf; specialize_Σ H0. sq. + intros. pose proof (abstract_env_ext_wf _ H0) as wf; specialize_Σ H0. sq. solve_all. simpl. destruct X as [[[isTy eq] sorts] eq']. simpl in *. assert(wf_local Σ (ind_params mdecl,,, indices)). @@ -1593,8 +1593,8 @@ Section CheckEnv. ret _ | exist None eqvu => raise (abstract_env_empty_ext abstract_env_empty, IllFormedDecl (string_of_kername id) (Msg "Ill-formed variance annotation")) }. Proof. - - destruct H0 as [? ?]; eauto. specialize_Σ H. - have [wfΣ] := abstract_env_ext_wf _ H0. sq. + - destruct H0 as [? ?]; eauto. specialize_Σ H. + have [wfΣ] := abstract_env_ext_wf _ H0. sq. destruct univs => //. symmetry in eqvu. destruct (variance_universes_spec _ _ _ _ _ _ _ _ eqvu). @@ -1657,7 +1657,7 @@ Section CheckEnv. end. - Lemma wf_decl_universes_subst_instance Σ udecl udecl' d u : + Lemma wf_decl_universes_subst_instance Σ udecl udecl' d u : wf_ext (Σ, udecl) -> wf_universe_instance (Σ, udecl') u -> wf_decl_universes (Σ, udecl) d -> @@ -1666,13 +1666,13 @@ Section CheckEnv. intros [wfΣ onud] cu. destruct d => /=; rewrite /wf_decl_universes /on_decl_universes /= . move/andP => [] ondbody ontype. - apply/andP; split. + apply/andP; split. 2:{ eapply (wf_universes_inst (Σ := (Σ, udecl')) udecl); cbn => //. apply onud. } destruct decl_body as [|] => /= //. eapply (wf_universes_inst (Σ := (Σ, udecl')) udecl); cbn => //. apply onud. Qed. - Lemma wf_ctx_universes_subst_instance Σ udecl udecl' Γ u : + Lemma wf_ctx_universes_subst_instance Σ udecl udecl' Γ u : wf_ext (Σ, udecl) -> wf_universe_instance (Σ, udecl') u -> wf_ctx_universes (Σ, udecl) Γ -> @@ -1685,7 +1685,7 @@ Section CheckEnv. eapply wf_decl_universes_subst_instance; tea. Qed. - Lemma wf_local_wf_ctx_universes {Σ Γ} : wf_ext Σ -> + Lemma wf_local_wf_ctx_universes {Σ Γ} : wf_ext Σ -> wf_local Σ Γ -> wf_ctx_universes Σ Γ. Proof using Type. intros wfΣ. unfold wf_ctx_universes. @@ -1694,62 +1694,62 @@ Section CheckEnv. cbn. move/typing_wf_universes: t1 => /=; rewrite /wf_decl_universes /on_decl_universes /= => -> /= //. Qed. - Lemma wf_ctx_universes_app {Σ Γ Δ} : + Lemma wf_ctx_universes_app {Σ Γ Δ} : wf_ctx_universes Σ (Γ ,,, Δ) = wf_ctx_universes Σ Γ && wf_ctx_universes Σ Δ. Proof using Type. now rewrite /wf_ctx_universes /app_context forallb_app andb_comm. Qed. - + Next Obligation. sq. by []. Qed. Next Obligation. - pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. + pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. specialize (mdeclvar _ wfΣ0). specialize_Σ wfΣ0. - destruct Xprop as [Xprop ?]; eauto. - unshelve erewrite (abstract_env_ext_irr _ _ (Xprop _ _)); eauto. + destruct Xprop as [Xprop ?]; eauto. + unshelve erewrite (abstract_env_ext_irr _ _ (Xprop _ _)); eauto. sq. symmetry in Heq_anonymous. destruct H0. specialize (H0 _ wfΣ0). apply abstract_env_ext_wf in H0. destruct H0. eapply variance_universes_spec in Heq_anonymous; tea. - eapply wf_ctx_universes_subst_instance; tea. + eapply wf_ctx_universes_subst_instance; tea. destruct Heq_anonymous. now eapply consistent_instance_ext_wf in c. destruct wfΓ. eapply wf_local_smash_end in a. eapply wf_local_expand_lets in a. eapply wf_local_wf_ctx_universes in a; tea. rewrite wf_ctx_universes_app in a. move/andP: a => [] //. - Qed. + Qed. Next Obligation. - pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. + pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. specialize (mdeclvar _ wfΣ0). specialize_Σ wfΣ0. - destruct Xprop as [Xprop ?]; eauto. + destruct Xprop as [Xprop ?]; eauto. unshelve erewrite (abstract_env_ext_irr _ _ (Xprop _ _)); eauto. sq. symmetry in Heq_anonymous. destruct H0. specialize (H0 _ wfΣ0). apply abstract_env_ext_wf in H0. destruct H0. eapply variance_universes_spec in Heq_anonymous; tea. - eapply wf_ctx_universes_subst_instance; tea. + eapply wf_ctx_universes_subst_instance; tea. destruct Heq_anonymous. now eapply consistent_instance_ext_wf in c0. destruct wfΓ. eapply wf_local_smash_end in a. eapply wf_local_expand_lets in a. eapply wf_local_wf_ctx_universes in a; tea. rewrite wf_ctx_universes_app in a. move/andP: a => [] //. - Qed. + Qed. Next Obligation. - pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. + pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. specialize (mdeclvar _ wfΣ0). specialize_Σ wfΣ0. - destruct Xprop as [Xprop ?]; eauto. - unshelve erewrite (abstract_env_ext_irr _ _ (Xprop _ _)); eauto. + destruct Xprop as [Xprop ?]; eauto. + unshelve erewrite (abstract_env_ext_irr _ _ (Xprop _ _)); eauto. sq. symmetry in Heq_anonymous. destruct H0. specialize (H0 _ wfΣ0). apply abstract_env_ext_wf in H0. destruct H0. eapply variance_universes_spec in Heq_anonymous; tea. - destruct Heq_anonymous as [c c0]. + destruct Heq_anonymous as [c c0]. destruct wfΓ as [wfargs wfinds]. eapply ctx_inst_wt in wfinds. solve_all. destruct H0 as [T wt]. rewrite -app_context_assoc in wt. @@ -1760,16 +1760,16 @@ Section CheckEnv. move/andP: wt => [] //. Qed. Next Obligation. - pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. + pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. specialize (mdeclvar _ wfΣ0). specialize_Σ wfΣ0. - destruct Xprop as [Xprop ?]; eauto. - unshelve erewrite (abstract_env_ext_irr _ _ (Xprop _ _)); eauto. + destruct Xprop as [Xprop ?]; eauto. + unshelve erewrite (abstract_env_ext_irr _ _ (Xprop _ _)); eauto. sq. symmetry in Heq_anonymous. destruct H0. specialize (H0 _ wfΣ0). apply abstract_env_ext_wf in H0. destruct H0. eapply variance_universes_spec in Heq_anonymous; tea. - destruct Heq_anonymous as [c c0]. + destruct Heq_anonymous as [c c0]. destruct wfΓ as [wfargs wfinds]. eapply ctx_inst_wt in wfinds. solve_all. destruct H0 as [T wt]. rewrite -app_context_assoc in wt. @@ -1780,17 +1780,17 @@ Section CheckEnv. move/andP: wt => [] //. Qed. Next Obligation. - pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. - destruct Xprop as [Xprop ?]; eauto. + pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. + destruct Xprop as [Xprop ?]; eauto. specialize (Xprop Σ0 wfΣ0). specialize_Σ Xprop. sq. intros v0 [= <-]. red. rewrite -Heq_anonymous. - split; auto. erewrite (abstract_env_irr _ _ wfΣ0); eauto. + split; auto. erewrite (abstract_env_irr _ _ wfΣ0); eauto. now apply leq_context_cumul_context. clear check_args. - eapply All2_impl. eauto. simpl; intros. erewrite (abstract_env_irr _ _ wfΣ0); eauto. + eapply All2_impl. eauto. simpl; intros. erewrite (abstract_env_irr _ _ wfΣ0); eauto. now eapply eq_term_upto_univ_cumulSpec. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. pose proof (abstract_env_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. sq. @@ -1803,19 +1803,19 @@ Section CheckEnv. (** Moving it causes a universe bug... *) Section MonadAllAll. - Context {AA : Type} {BB : AA -> Type} {T : Type -> Type} {M : Monad T} {A} {P : forall (aa:AA), BB aa -> A -> Type} {Q : forall (aa:AA), BB aa -> A -> Type} + Context {AA : Type} {BB : AA -> Type} {T : Type -> Type} {M : Monad T} {A} {P : forall (aa:AA), BB aa -> A -> Type} {Q : forall (aa:AA), BB aa -> A -> Type} (f : forall x, (forall aa bb, ∥ Q aa bb x ∥) -> T (forall aa bb, ∥ P aa bb x ∥)). - Program Fixpoint monad_All_All l : - (forall (aa:AA) (bb: BB aa), ∥ All (Q aa bb) l ∥) -> - T (forall (aa:AA) (bb:BB aa), ∥ All (P aa bb) l ∥) := + Program Fixpoint monad_All_All l : + (forall (aa:AA) (bb: BB aa), ∥ All (Q aa bb) l ∥) -> + T (forall (aa:AA) (bb:BB aa), ∥ All (P aa bb) l ∥) := match l return (forall (aa:AA) (bb: BB aa), ∥ All (Q aa bb) l ∥) -> T (forall (aa:AA) (bb:BB aa) , ∥ All (P aa bb) l ∥) with | [] => fun _ => ret (fun aa bb => sq All_nil) - | a :: l => fun allq => + | a :: l => fun allq => X <- f a _ ;; Y <- monad_All_All l _ ;; ret (fun aa bb => _) end. - Next Obligation. + Next Obligation. specialize_Σ bb. sq. now depelim allq. Qed. Next Obligation. @@ -1827,21 +1827,21 @@ Section CheckEnv. End MonadAllAll. Section MonadLiftExt. - Context {X:X_env_type} {X_ext:X_env_ext_type} {ext:universes_decl} - {T : Type -> Type} {M : Monad T} - {P : forall (Σ:global_env), abstract_env_rel X Σ -> Type} + Context {X:X_env_type} {X_ext:X_env_ext_type} {ext:universes_decl} + {T : Type -> Type} {M : Monad T} + {P : forall (Σ:global_env), abstract_env_rel X Σ -> Type} (XX_ext : forall (Σ:global_env_ext), abstract_env_ext_rel X_ext Σ -> abstract_env_rel X Σ.1) (XX_ext' : forall (Σ:global_env), abstract_env_rel X Σ -> abstract_env_ext_rel X_ext (Σ,ext)). - Program Definition monad_lift_ext : + Program Definition monad_lift_ext : T (forall (Σ:global_env) (wfΣ : abstract_env_rel X Σ), P Σ wfΣ) -> - T (forall (Σ:global_env_ext) (wfΣ : abstract_env_ext_rel X_ext Σ), P Σ (XX_ext Σ wfΣ)) := fun x => + T (forall (Σ:global_env_ext) (wfΣ : abstract_env_ext_rel X_ext Σ), P Σ (XX_ext Σ wfΣ)) := fun x => f <- x ;; - ret _. + ret _. End MonadLiftExt. - Program Definition check_constructors X X_ext + Program Definition check_constructors X X_ext (id : kername) (mdecl : mutual_inductive_body) (HX : check_wf_env_ext_prop X X_ext (ind_universes mdecl)) (wfar : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_ind_types Σ mdecl ∥) @@ -1855,32 +1855,32 @@ Section CheckEnv. '(cs; Hcs) <- (check_constructors_univs X_ext (string_of_kername id) mdecl wfar wfpars (S n) idecl.(ind_ctors));; - posc <- wrap_error _ X_ext (string_of_kername id) - (monad_All_All + posc <- wrap_error _ X_ext (string_of_kername id) + (monad_All_All (fun x px => @check_positive_cstr X_ext mdecl n (arities_context mdecl.(ind_bodies)) (cstr_type x) _ []) idecl.(ind_ctors) (wt_cstrs (cs:=cs) X_ext Hcs)) ;; - var <- (monad_All_All - (fun cs px => @monad_lift_ext X X_ext (EnvCheck X_env_ext_type) _ _ _ - (check_cstr_variance X mdecl id indices mdeclvar cs _ _)) + var <- (monad_All_All + (fun cs px => @monad_lift_ext X X_ext (EnvCheck X_env_ext_type) _ _ _ + (check_cstr_variance X mdecl id indices mdeclvar cs _ _)) idecl.(ind_ctors) (get_wt_indices X_ext wfar wfpars n idecl indices hnth heq Hcs)) ;; - lets <- + lets <- monad_All (P := fun x => if @lets_in_constructor_types _ as _ return Prop then true else is_assumption_context (cstr_args x)) (fun cs => if @lets_in_constructor_types _ then ret _ else - (if is_assumption_context (cstr_args cs) then ret _ - else EnvError X_env_ext_type X_ext + (if is_assumption_context (cstr_args cs) then ret _ + else EnvError X_env_ext_type X_ext (IllFormedDecl "No lets in constructor types allowed, you need to set the checker flag lets_in_constructor_types to [true]." (Msg "No lets in constructor types allowed, you need to set the checker flag lets_in_constructor_types to [true].") )) - ) idecl.(ind_ctors) ;; + ) idecl.(ind_ctors) ;; ret (cs; _). Next Obligation. specialize_Σ H. now sq. Qed. - Next Obligation. destruct HX as [? HX]; eauto. Qed. + Next Obligation. destruct HX as [? HX]; eauto. Qed. Next Obligation. specialize_Σ H. destruct HX as [? ?]. specialize_Σ H. now pose proof (abstract_env_ext_wf _ H0). Qed. Next Obligation. specialize_Σ H. now destruct HX as [? ?]. Qed. - Next Obligation. + Next Obligation. destruct lets_in_constructor_types. + reflexivity. + red. congruence. @@ -1954,7 +1954,7 @@ Section CheckEnv. Section monad_Alli_nth_forall. Context {AA : Type} {BB : AA -> Type} {T} {M : Monad T} {A} {P : forall (aa:AA), BB aa -> nat -> A -> Type}. Program Fixpoint monad_Alli_nth_gen_forall l k - (f : forall n x, nth_error l n = Some x -> T (forall aa bb, ∥ P aa bb (k + n) x ∥)) : + (f : forall n x, nth_error l n = Some x -> T (forall aa bb, ∥ P aa bb (k + n) x ∥)) : T (forall aa bb, ∥ @Alli A (P aa bb) k l ∥) := match l with | [] => ret (fun _ _ => sq Alli_nil) @@ -1969,7 +1969,7 @@ Section CheckEnv. specialize_Σ bb. sq. rewrite Nat.add_0_r in X. constructor; auto. Qed. - Definition monad_Alli_nth_forall l (f : forall n x, nth_error l n = Some x -> T (forall aa bb, ∥ P aa bb n x ∥)) : + Definition monad_Alli_nth_forall l (f : forall n x, nth_error l n = Some x -> T (forall aa bb, ∥ P aa bb n x ∥)) : T (forall aa bb, ∥ @Alli A (P aa bb) 0 l ∥) := monad_Alli_nth_gen_forall l 0 f. @@ -1987,15 +1987,15 @@ End monad_Alli_nth_forall. check_length <- check_eq_true (eqb #|idecl.(ind_projs)| (context_assumptions cdecl.(cstr_args))) (Msg "Invalid number of projections") ;; check_projs <- monad_Alli_nth_forall idecl.(ind_projs) - (fun n p hnth => check_projection X_ext mind mdecl i idecl indices cdecl cs oncs n p hnth (eqb_eq _ _ check_length)) ;; + (fun n p hnth => check_projection X_ext mind mdecl i idecl indices cdecl cs oncs n p hnth (eqb_eq _ _ check_length)) ;; ret _. - + Next Obligation. specialize_Σ H. sq. depelim oncs. depelim oncs. eapply eqb_eq in check_indices; subst indices. eapply eqb_eq in check_elim. eapply eqb_eq in check_length. constructor => //. - Qed. + Qed. Program Definition check_projections X_ext (mind : kername) (mdecl : mutual_inductive_body) (i : nat) (idecl : one_inductive_body) (indices : context) (cs : list constructor_univs) : @@ -2009,13 +2009,13 @@ End monad_Alli_nth_forall. ccs <- check_projections_cs X_ext mind mdecl i idecl indices cdecl cs _ _ ;; ret _ | _, _ => fun oncs => raise (Msg "Projections can only be declared for an inductive type with a single constructor") - end + end end. Next Obligation. rename Heq_anonymous into eqp. sq. red. rewrite -eqp. congruence. Qed. - Next Obligation. specialize_Σ H. sq. rewrite Heq_x. eauto. Qed. + Next Obligation. specialize_Σ H. sq. rewrite Heq_x. eauto. Qed. Next Obligation. specialize_Σ H. sq. red. intros. rewrite -Heq_x //. Qed. @@ -2025,14 +2025,14 @@ End monad_Alli_nth_forall. Definition wf_cs_sorts X_ext cs := forall Σ, abstract_env_ext_rel X_ext Σ -> Forall (Forall (wf_universe Σ)) cs. - + Lemma check_constructors_smallerP X_ext cs ind_sort : - wf_cs_sorts X_ext cs -> + wf_cs_sorts X_ext cs -> (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_universe Σ ind_sort) -> forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ reflect (check_constructors_smaller Σ cs ind_sort) (checkb_constructors_smaller X_ext cs ind_sort) ∥. Proof using Type. unfold check_constructors_smaller, checkb_constructors_smaller. - intros wfcs wfind ? ?. specialize_Σ H. + intros wfcs wfind ? ?. specialize_Σ H. sq. eapply forallbP_cond; eauto. clear wfcs. simpl; intros c wfc. @@ -2040,7 +2040,7 @@ End monad_Alli_nth_forall. apply iff_reflect. apply (abstract_env_compare_universe_correct _ H Cumul); eauto. Qed. - Program Definition do_check_ind_sorts X_ext (params : context) + Program Definition do_check_ind_sorts X_ext (params : context) (wfparams : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ params ∥) (kelim : allowed_eliminations) (indices : context) (cs : list constructor_univs) @@ -2122,44 +2122,44 @@ End monad_Alli_nth_forall. sq. discriminate. Qed. Next Obligation. - pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. + pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. specialize (mdeclvar _ wfΣ0). specialize_Σ wfΣ0. - destruct H0 as [Xprop ?]; eauto. + destruct H0 as [Xprop ?]; eauto. unshelve erewrite (abstract_env_ext_irr _ _ (Xprop _ _)); eauto. sq. symmetry in Heq_anonymous. specialize (Xprop _ wfΣ0). apply abstract_env_ext_wf in Xprop. destruct Xprop. eapply variance_universes_spec in Heq_anonymous as [cu cu']; tea. - eapply wf_ctx_universes_subst_instance; tea. + eapply wf_ctx_universes_subst_instance; tea. now eapply consistent_instance_ext_wf in cu. move/wf_local_smash_end: wfΓ. rewrite -[_ ,,, _]app_context_nil_l app_context_assoc. move/wf_local_expand_lets; rewrite app_context_nil_l. move/wf_local_wf_ctx_universes. rewrite wf_ctx_universes_app. move/andP => [] //. - Qed. + Qed. Next Obligation. - pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. + pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. specialize (mdeclvar _ wfΣ0). specialize_Σ wfΣ0. - destruct H0 as [Xprop ?]; eauto. + destruct H0 as [Xprop ?]; eauto. unshelve erewrite (abstract_env_ext_irr _ _ (Xprop _ _)); eauto. sq. symmetry in Heq_anonymous. specialize (Xprop _ wfΣ0). apply abstract_env_ext_wf in Xprop. destruct Xprop. eapply variance_universes_spec in Heq_anonymous as [cu cu']; tea. - eapply wf_ctx_universes_subst_instance; tea. + eapply wf_ctx_universes_subst_instance; tea. now eapply consistent_instance_ext_wf in cu'. move/wf_local_smash_end: wfΓ. rewrite -[_ ,,, _]app_context_nil_l app_context_assoc. move/wf_local_expand_lets; rewrite app_context_nil_l. move/wf_local_wf_ctx_universes. rewrite wf_ctx_universes_app. move/andP => [] //. - Qed. + Qed. Next Obligation. - destruct eq as [? ?]; eauto. specialize_Σ H. - specialize_Σ H1. + destruct eq as [? ?]; eauto. specialize_Σ H. + specialize_Σ H1. rename Heq_anonymous0 into eqvar. - rename Heq_anonymous into eqvaru. + rename Heq_anonymous into eqvaru. sq. intros ? [= <-]. red. simpl. rewrite -eqvaru. unfold variance_universes in eqvaru. @@ -2190,7 +2190,7 @@ End monad_Alli_nth_forall. solve_all. now exists y. Qed. - Program Definition check_one_ind_body X X_ext + Program Definition check_one_ind_body X X_ext (mind : kername) (mdecl : mutual_inductive_body) (pf : check_wf_env_ext_prop X X_ext (ind_universes mdecl)) (wfpars : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ mdecl.(ind_params) ∥) @@ -2204,7 +2204,7 @@ End monad_Alli_nth_forall. wrap_error _ X_ext id ((match destArity [] idecl.(ind_type) as da return da = destArity [] idecl.(ind_type) -> typing_result (∑ ctxs, idecl.(ind_type) = it_mkProd_or_LetIn ctxs.1 (tSort ctxs.2)) with | Some (ctx, s) => fun eq => ret ((ctx, s); _) | None => fun _ => raise (NotAnArity idecl.(ind_type)) - end eq_refl)) ;; + end eq_refl)) ;; let '(indices, params) := split_at (#|ctxinds.1| - #|mdecl.(ind_params)|) ctxinds.1 in eqsort <- wrap_error _ X_ext id (check_eq_true (eqb ctxinds.2 idecl.(ind_sort)) @@ -2215,14 +2215,14 @@ End monad_Alli_nth_forall. eqindices <- wrap_error _ X_ext id (check_eq_true (eqb indices idecl.(ind_indices)) (Msg "Inductive arity indices do not match the indices of the mutual declaration"));; - '(cs; oncstrs) <- (check_constructors X X_ext mind mdecl pf wfars wfpars mdeclvar i idecl idecl.(ind_indices) hnth _) ;; + '(cs; oncstrs) <- (check_constructors X X_ext mind mdecl pf wfars wfpars mdeclvar i idecl idecl.(ind_indices) hnth _) ;; onprojs <- wrap_error _ X_ext ("Checking projections of " ^ id) (check_projections X_ext mind mdecl i idecl idecl.(ind_indices) cs oncstrs) ;; onsorts <- wrap_error _ X_ext ("Checking universes of " ^ id) (do_check_ind_sorts X_ext mdecl.(ind_params) wfpars idecl.(ind_kelim) idecl.(ind_indices) cs _ ctxinds.2 _) ;; - onindices <- check_indices X mdecl mind _ mdeclvar idecl.(ind_indices) _ ;; - ret _. + onindices <- check_indices X mdecl mind _ mdeclvar idecl.(ind_indices) _ ;; + ret _. Next Obligation. symmetry in eq. apply destArity_spec_Some in eq. now simpl in eq. @@ -2235,38 +2235,38 @@ End monad_Alli_nth_forall. rewrite {1}H. apply eqb_eq in eqindices. rewrite -eqindices. now rewrite /app_context firstn_skipn. Qed. - + Next Obligation. - intros ? ?. pose proof (abstract_env_ext_wf _ H). + intros ? ?. pose proof (abstract_env_ext_wf _ H). destruct pf as [pf ?]. specialize_Σ H. destruct Σ as [Σ ext]. pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. specialize_Σ wfΣ0. pose proof (abstract_env_ext_wf _ pf) as wf. sq. clear - H pf X0 wf. induction X0; eauto. constructor; eauto. destruct r. - eapply sorts_local_ctx_wf_sorts; eauto. - erewrite (abstract_env_ext_irr _ _ pf); eauto. + eapply sorts_local_ctx_wf_sorts; eauto. + erewrite (abstract_env_ext_irr _ _ pf); eauto. Unshelve. eauto. Qed. Next Obligation. cbn in *. specialize_Σ H. sq. pose proof (abstract_env_ext_wf _ H). destruct Σ as [Σ ext]. - pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. + pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. destruct pf as [pf ?]; eauto. specialize_Σ H. specialize_Σ wfΣ0. pose proof (abstract_env_ext_wf _ pf). sq. eapply nth_error_all in wfars; eauto; simpl in wfars. destruct wfars as [s Hs]. clear X0; rewrite p in Hs. eapply PCUICSpine.inversion_it_mkProd_or_LetIn in Hs; eauto. - eapply inversion_Sort in Hs as [_ [? _]]; eauto. + eapply inversion_Sort in Hs as [_ [? _]]; eauto. Qed. Next Obligation. destruct pf as [pf ?]; specialize_Σ H. now pose proof (abstract_env_ext_wf _ pf). Qed. - Next Obligation. - destruct pf as [pf pf']. specialize_Σ H. specialize_Σ pf. - pose proof (abstract_env_ext_wf _ pf) as wf. - sq. + Next Obligation. + destruct pf as [pf pf']. specialize_Σ H. specialize_Σ pf. + pose proof (abstract_env_ext_wf _ pf) as wf. + sq. clear onprojs onsorts X0. red in wfars. eapply nth_error_all in wfars; eauto; simpl in wfars. destruct wfars as [s Hs]. @@ -2278,14 +2278,14 @@ End monad_Alli_nth_forall. eapply PCUICSpine.inversion_it_mkProd_or_LetIn in Hs; eauto. eapply typing_wf_local in Hs. now rewrite app_context_nil_l in Hs. Qed. - + Next Obligation. rename X0 into oncstrs. rename x into cs. destruct Σ as [Σ ext]. - pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. - destruct pf as [pf pf']; eauto. specialize_Σ H. specialize_Σ wfΣ0. + pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. + destruct pf as [pf pf']; eauto. specialize_Σ H. specialize_Σ wfΣ0. destruct (eqb_spec params (ind_params mdecl)); [|discriminate]. subst params. sq. - refine + refine {| ind_arity_eq := _; onArity := _; ind_cunivs := cs; onConstructors := oncstrs; @@ -2301,18 +2301,18 @@ End monad_Alli_nth_forall. - now apply eqb_eq in eqsort; subst. - erewrite (abstract_env_ext_irr _ _ pf); eauto. Unshelve. eauto. - Qed. + Qed. - Program Definition check_wf_decl X X_ext + Program Definition check_wf_decl X X_ext kn (d : global_decl) (pf : check_wf_env_ext_prop X X_ext (universes_decl_of_decl d)) : EnvCheck X_env_ext_type (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ on_global_decl cumulSpec0 (lift_typing typing) Σ kn d ∥) := match d with - | ConstantDecl cst => + | ConstantDecl cst => match cst.(cst_body) with - | Some term => + | Some term => check_wf_judgement kn X_ext term cst.(cst_type) ;; ret _ - | None => check_wf_type kn X_ext cst.(cst_type) ;; ret _ + | None => check_wf_type kn X_ext cst.(cst_type) ;; ret _ end | InductiveDecl mdecl => let id := string_of_kername kn in @@ -2322,7 +2322,7 @@ End monad_Alli_nth_forall. (check_eq_nat (context_assumptions (ind_params mdecl)) (ind_npars mdecl) (Msg "wrong number of parameters")) ;; onarities <- check_ind_types X_ext mdecl ;; - check_bodies <- monad_Alli_nth_forall mdecl.(ind_bodies) (fun i oib Hoib => check_one_ind_body X X_ext kn mdecl _ check_pars onarities check_var i oib Hoib);; + check_bodies <- monad_Alli_nth_forall mdecl.(ind_bodies) (fun i oib Hoib => check_one_ind_body X X_ext kn mdecl _ check_pars onarities check_var i oib Hoib);; ret (Build_on_inductive_sq check_bodies check_pars check_npars _) end. Next Obligation. @@ -2338,14 +2338,14 @@ End monad_Alli_nth_forall. Obligation Tactic := idtac. Next Obligation. intros. cbn in *. rewrite <- Heq_d in pf. exact pf. - Qed. + Qed. Next Obligation. - intros. destruct pf as [pf pf']. specialize_Σ H. - pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. - specialize_Σ wfΣ0. + intros. destruct pf as [pf pf']. specialize_Σ H. + pose proof (abstract_env_exists X) as [[Σ0 wfΣ0]]. + specialize_Σ wfΣ0. sq. now erewrite (abstract_env_ext_irr _ _ pf). - Unshelve. eauto. - Qed. + Unshelve. eauto. + Qed. Import EnvMap. @@ -2358,13 +2358,13 @@ End monad_Alli_nth_forall. LevelSet.mem Level.lzero (ContextSet.levels univs) -> LevelSet.Equal (PCUICLookup.global_levels univs) (ContextSet.levels univs). Proof using Type. - clear. move / LevelSet.mem_spec. intros Hin l. unfold global_levels. rewrite LS.union_spec LevelSet.singleton_spec. - lsets. + clear. move / LevelSet.mem_spec. intros Hin l. unfold global_levels. rewrite LS.union_spec LevelSet.singleton_spec. + lsets. Qed. Program Definition check_univs (univs : ContextSet.t) (retro : Retroknowledge.t) - : EnvCheck X_env_ext_type ({ X : X_env_type | - (forall Σ, abstract_env_rel X Σ -> Σ = {| universes := univs; declarations := []; retroknowledge := retro |}) + : EnvCheck X_env_ext_type ({ X : X_env_type | + (forall Σ, abstract_env_rel X Σ -> Σ = {| universes := univs; declarations := []; retroknowledge := retro |}) /\ ∥ on_global_univs univs ∥ }) := let id := "toplevel" in let levels := ContextSet.levels univs in @@ -2380,7 +2380,7 @@ End monad_Alli_nth_forall. | Some uctx => fun _ => check_eq_true_lazy (@abstract_env_is_consistent _ X_env_type X_env_ext_type _ uctx) (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg "constraints not satisfiable"))) ;; ret (let Hunivs := _ in exist (abstract_env_init univs retro Hunivs) _) end eq_refl . - Next Obligation. + Next Obligation. intros. have decll : ConstraintSet.For_all (declared_cstr_levels (ContextSet.levels univs)) (ContextSet.constraints univs). { clear -i1. apply ConstraintSet.for_all_spec in i1. @@ -2391,45 +2391,45 @@ End monad_Alli_nth_forall. now split. } intros. split; eauto. { intros l Hl. specialize (decll l Hl). red. destruct l, p. now rewrite levels_global_levels_declared. } - split; eauto. unfold declared_cstr_levels. cbn. + split; eauto. unfold declared_cstr_levels. cbn. repeat split => //. + clear - i i0. apply LevelSet.for_all_spec in i0. 2: now intros x y []. - intros l Hl. rewrite levels_global_levels_declared in Hl; eauto. - + cbn in e. rename e into Huctx. + intros l Hl. rewrite levels_global_levels_declared in Hl; eauto. + + cbn in e. rename e into Huctx. eapply (abstract_env_is_consistent_correct uctx univs); eauto. case_eq (gc_of_constraints univs.2); [|intro XX; rewrite XX in Huctx; noconf Huctx]. intros Σctrs HΣctrs. unfold global_ext_constraints. simpl in *. rewrite HΣctrs in Huctx. sq. split. - * clear -i. destruct univs. cbn in *. now apply LevelSet.mem_spec in i. + * clear -i. destruct univs. cbn in *. now apply LevelSet.mem_spec in i. * red. apply decll. - Qed. - Next Obligation. + Qed. + Next Obligation. cbv beta. intros univs retro id levels X H H0 Hconsistent ? ? Hunivs. clearbody Hunivs. split. - intros. eapply (abstract_env_irr _ _ (abstract_env_init_correct _ _ _)); eauto. - now sq. - Unshelve. eauto. + Unshelve. eauto. Qed. Obligation Tactic := Tactics.program_simpl. Program Fixpoint check_wf_decls (univs : ContextSet.t) (retro : Retroknowledge.t) - (decls : global_declarations) : EnvCheck X_env_ext_type ({ X : X_env_type | + (decls : global_declarations) : EnvCheck X_env_ext_type ({ X : X_env_type | (forall Σ, abstract_env_rel X Σ -> Σ = {| universes := univs; declarations := decls; retroknowledge := retro |})}) - := + := match decls with - [] => - X <- check_univs univs retro ;; + [] => + X <- check_univs univs retro ;; ret (exist (proj1_sig X) _) - | d :: decls => - '(exist X wf_) <- check_wf_decls univs retro decls ;; + | d :: decls => + '(exist X wf_) <- check_wf_decls univs retro decls ;; isfresh <- check_fresh d.1 decls ;; let udecl := universes_decl_of_decl d.2 in X' <- make_abstract_env_ext X d.1 udecl ;; - check_wf_decl X (proj1_sig X') d.1 d.2 (proj2_sig X') ;; + check_wf_decl X (proj1_sig X') d.1 d.2 (proj2_sig X') ;; ret (exist (abstract_env_add_decl X d.1 d.2 _) _) end. Next Obligation. @@ -2440,40 +2440,40 @@ End monad_Alli_nth_forall. now rewrite wf_. - pose proof (abstract_env_ext_wf _ H). sq. destruct H2. cbn in *. rewrite wf_ in o0. erewrite <- abstract_env_univ_correct ; eauto. - now rewrite wf_ in a. - - rewrite wf_ in y. erewrite <- abstract_env_univ_correct ; eauto. + now rewrite wf_ in a. + - rewrite wf_ in y. erewrite <- abstract_env_univ_correct ; eauto. erewrite <- abstract_env_global_declarations_correct; eauto. erewrite <- (abstract_env_retroknowledge_correct); eauto. now rewrite wf_. Qed. Next Obligation. - pose proof (abstract_env_exists X) as [[? ?]]. + pose proof (abstract_env_exists X) as [[? ?]]. epose (abstract_env_add_decl_correct X _ k g _ a). erewrite (abstract_env_irr _ H a0). pose proof (wf_ _ a) as eq. - unfold add_global_decl. now rewrite eq. - Qed. - - Program Definition check_wf_env (Σ : global_env) : - EnvCheck X_env_ext_type ({ X : X_env_type | abstract_env_rel X Σ}) := + unfold add_global_decl. now rewrite eq. + Qed. + + Program Definition check_wf_env (Σ : global_env) : + EnvCheck X_env_ext_type ({ X : X_env_type | abstract_env_rel X Σ}) := X <- check_wf_decls Σ.(universes) Σ.(retroknowledge) Σ.(declarations) ;; ret (exist (proj1_sig X) _). - Next Obligation. + Next Obligation. pose proof (abstract_env_exists X) as [[Σ' wfΣ]]. specialize_Σ wfΣ. subst. now destruct Σ. Qed. - Program Definition check_wf_ext (Σ : global_env_ext) : + Program Definition check_wf_ext (Σ : global_env_ext) : EnvCheck X_env_ext_type ({ X : X_env_ext_type | abstract_env_ext_rel X Σ}) := X <- check_wf_env Σ.1 ;; X' <- make_abstract_env_ext (proj1_sig X) (MPfile [], "toplevel term") Σ.2 ;; ret (exist (proj1_sig X') _). - Next Obligation. + Next Obligation. specialize_Σ a. now destruct H as [? ?], Σ. - Qed. + Qed. Definition check_type_wf_env_bool X_ext Γ (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ Γ ∥) t T : bool := @@ -2483,8 +2483,8 @@ End monad_Alli_nth_forall. end. Definition check_wf_env_bool_spec X_ext Γ - (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ Γ ∥) t T : - check_type_wf_env_bool X_ext Γ wfΓ t T = true -> + (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ Γ ∥) t T : + check_type_wf_env_bool X_ext Γ wfΓ t T = true -> forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ Σ ;;; Γ |- t : T ∥. Proof using Type. unfold check_type_wf_env_bool. @@ -2493,7 +2493,7 @@ End monad_Alli_nth_forall. Qed. Definition check_wf_env_bool_spec2 X_ext Γ - (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ Γ ∥) t T : + (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ Γ ∥) t T : check_type_wf_env_bool X_ext Γ wfΓ t T = false -> type_error. Proof. unfold check_type_wf_env_bool. @@ -2505,7 +2505,7 @@ End monad_Alli_nth_forall. it forgets about the derivation produced by typing and replaces it with an opaque constant. *) Program Definition check_type_wf_env_fast X_ext Γ - (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ Γ ∥) t {T} : + (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ Γ ∥) t {T} : typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ Σ ;;; Γ |- t : T ∥) := (if check_type_wf_env_bool X_ext Γ wfΓ t T as x return (check_type_wf_env_bool X_ext Γ wfΓ t T = x -> typing_result _) then fun eq => ret _ @@ -2517,12 +2517,12 @@ End monad_Alli_nth_forall. Obligation Tactic := Program.Tactics.program_simpl. - Definition EnvCheck_X_env_ext_type {cf:checker_flags} := EnvCheck X_env_ext_type. + Definition EnvCheck_X_env_ext_type {cf:checker_flags} := EnvCheck X_env_ext_type. Instance Monad_EnvCheck_X_env_ext_type {cf:checker_flags} : Monad EnvCheck_X_env_ext_type := _. Program Definition typecheck_program (p : program) φ - : EnvCheck_X_env_ext_type (∑ A, { X: X_env_ext_type | ∥ abstract_env_ext_rel X (p.1, φ) × + : EnvCheck_X_env_ext_type (∑ A, { X: X_env_ext_type | ∥ abstract_env_ext_rel X (p.1, φ) × wf_ext (p.1, φ) × (p.1, φ) ;;; [] |- p.2 ▹ A ∥}) := '(exist xx pf) <- check_wf_ext (p.1, φ) ;; inft <- infer_term xx p.2 ;; diff --git a/safechecker/theories/PCUICSafeConversion.v b/safechecker/theories/PCUICSafeConversion.v index d309aeabb..68a9b5d86 100644 --- a/safechecker/theories/PCUICSafeConversion.v +++ b/safechecker/theories/PCUICSafeConversion.v @@ -8,7 +8,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrincipality PCUICContextConversion PCUICContextConversionTyp PCUICSN PCUICUtils PCUICWfUniverses PCUICOnFreeVars PCUICWellScopedCumulativity PCUICWeakeningEnvConv PCUICWeakeningEnvTyp - PCUICWeakeningConv PCUICWeakeningTyp + PCUICWeakeningConv PCUICWeakeningTyp PCUICClosed PCUICClosedTyp PCUICConvCumInversion . From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnv PCUICSafeReduce PCUICEqualityDec. @@ -64,11 +64,11 @@ Section Conversion. Context (X : X_type.π2.π1). - Local Definition heΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : + Local Definition heΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : ∥ wf_ext Σ ∥ := abstract_env_ext_wf _ wfΣ. Local Definition hΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : - ∥ wf Σ ∥ := abstract_env_ext_sq_wf _ _ _ wfΣ. + ∥ wf Σ ∥ := abstract_env_ext_sq_wf _ _ _ wfΣ. Set Equations Transparent. Set Equations With UIP. @@ -147,14 +147,14 @@ Section Conversion. forall Γ, well_founded (wcored Γ). Proof using Type. intros Γ [u hu]. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (heΣ _ wfΣ) as heΣ. pose proof (hu _ wfΣ) as h. apply normalisation_upto in h. 2: exact heΣ. dependent induction h. constructor. intros [y hy] r. unfold wcored in r. cbn in r. - eapply H0. eapply r; eauto. + eapply H0. eapply r; eauto. Qed. Import PCUICAlpha. @@ -180,14 +180,14 @@ Section Conversion. Proof using X. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. intros u v p vp e. - destruct e as [e']. + destruct e as [e']. eapply eq_term_valid_pos. all: eauto. now eapply eqt_eqterm. Unshelve. all:eauto. Qed. Definition weqt {Γ} (u v : wterm Γ) := eqt (` u) (` v). - + Equations R_aux (Γ : context) : (∑ t : term, pos t × (∑ w : wterm Γ, pos (` w) × state)) -> (∑ t : term, pos t × (∑ w : wterm Γ, pos (` w) × state)) -> Prop := @@ -213,7 +213,7 @@ Section Conversion. Defined. Derive Signature for Subterm.lexprod. - + Lemma R_aux_Acc : forall Γ t p w q s, (forall Σ, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) -> @@ -231,11 +231,11 @@ Section Conversion. unshelve eapply dlexmod_Acc. * intros x y [e]; eauto. constructor. now symmetry. * intros x y z [e1] [e2]; eauto. constructor. - now etransitivity; tea. + now etransitivity; tea. * intros [t' h']. eapply Subterm.wf_lexprod. -- intro. eapply posR_Acc. -- intro. eapply stateR_Acc. - * intros x x' y [e] [y' [x'' [r [[e1] [e2]]]]]; eauto. + * intros x x' y [e] [y' [x'' [r [[e1] [e2]]]]]; eauto. eexists _,_. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. intuition eauto using sq. constructor. etransitivity; tea. @@ -258,7 +258,7 @@ Section Conversion. * intros [t1 ht1] [t2 ht2] e [[q1 hq1] s1] [[q2 hq2] s2] h. destruct e as [e']. simpl in *. - dependent destruction h. + dependent destruction h. -- left. unfold posR in *. simpl in *. assumption. -- match goal with | |- context [ exist q1 ?hq1 ] => @@ -275,7 +275,7 @@ Section Conversion. simpl. f_equal. f_equal. eapply uip. - intros x x' [[q' h] [? [? ?]]] e. - destruct e as [e']; eauto. + destruct e as [e']; eauto. unfold R_aux_obligations_obligation_1. simpl. f_equal. f_equal. eapply uip. @@ -286,7 +286,7 @@ Section Conversion. - intros x x' e [[p1 hp1] [[u hu] [[q1 hq1] s1]]] [[p2 hp2] [[v hv] [[q2 hq2] s2]]] hl. - destruct e as [e']; eauto. + destruct e as [e']; eauto. simpl in *. dependent destruction hl. + left. unfold posR in *. @@ -304,11 +304,11 @@ Section Conversion. -- left. unfold posR in *. simpl in *. assumption. -- right. assumption. - - pose proof (heΣ _ wfΣ). + - pose proof (heΣ _ wfΣ). eapply Acc_equiv; try eapply normalisation_upto; eauto. split; eauto; intros. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Notation pzt u := (zipc (tm1 u) (stk1 u)) (only parsing). @@ -334,9 +334,9 @@ Section Conversion. Qed. Notation eq_term Σ t u := (eq_term Σ Σ t u). - - Lemma R_aux_irrelevance Γ x y z : - ((x.π1; x.π2.1), (existT (fun x => pos x × state) (` x.π2.2.π1) x.π2.2.π2)) = + + Lemma R_aux_irrelevance Γ x y z : + ((x.π1; x.π2.1), (existT (fun x => pos x × state) (` x.π2.2.π1) x.π2.2.π2)) = ((y.π1; y.π2.1), (existT (fun x => pos x × state) (` y.π2.2.π1) y.π2.2.π2)) -> R_aux Γ z x -> R_aux Γ z y. Proof using Type. @@ -360,8 +360,8 @@ Section Conversion. { constructor 2. exact H. } Qed. - Lemma R_irrelevance Γ x y z : - (x.(st), x.(tm1), x.(stk1), x.(tm2), x.(stk2)) = + Lemma R_irrelevance Γ x y z : + (x.(st), x.(tm1), x.(stk1), x.(tm2), x.(stk2)) = (y.(st), y.(tm1), y.(stk1), y.(tm2), y.(stk2)) -> R Γ z x -> R Γ z y. Proof using Type. @@ -429,7 +429,7 @@ Section Conversion. forall Γ p1 p2, (eqt (pzt p1) (pzt p2)) -> ` (pps1 p1) = ` (pps1 p2) -> - (forall Σ (wfΣ : abstract_env_ext_rel X Σ), + (forall Σ (wfΣ : abstract_env_ext_rel X Σ), cored Σ Γ (` (pwt p1)) (` (pwt p2))) -> R Γ p1 p2. Proof using Type. @@ -529,11 +529,11 @@ Section Conversion. Definition eqb_term_stack t1 π1 t2 π2 := eqb_ctx (stack_context π1) (stack_context π2) && - eqb_term (zipp t1 π1) (zipp t2 π2). + eqb_term (zipp t1 π1) (zipp t2 π2). - Lemma iff_reflect (P : Prop) (b : bool) : + Lemma iff_reflect (P : Prop) (b : bool) : P <-> b -> reflect P b. - Proof using Type. + Proof using Type. intro H. apply ssrbool.introP. - intuition. - destruct b; intuition. @@ -541,15 +541,15 @@ Section Conversion. Definition wf_universe_iff Σ u : wf_universeb Σ u <-> wf_universe Σ u. - Proof using Type. + Proof using Type. symmetry; apply reflect_iff. eapply wf_universe_reflect. - Qed. + Qed. Definition wf_universe_instance_iff Σ u : wf_universeb_instance Σ u <-> wf_universe_instance Σ u. - Proof using Type. + Proof using Type. symmetry; apply reflect_iff. eapply wf_universe_instanceP. - Qed. + Qed. Notation conv_stack_ctx Γ π1 π2 := (forall Σ, abstract_env_ext_rel X Σ -> ∥ (Σ ⊢ Γ ,,, stack_context π1 = Γ ,,, stack_context π2) ∥). @@ -572,7 +572,7 @@ Section Conversion. Definition isred_full Γ t π := isApp t = false /\ forall Σ, abstract_env_ext_rel X Σ -> ∥whnf RedFlags.nodelta Σ (Γ,,, stack_context π) (zipp t π)∥. - + Lemma isred_full_nobeta Γ t π : isred_full Γ t π -> isLambda t -> @@ -584,7 +584,7 @@ Section Conversion. destruct π as [|[]]; cbn in *; try easy. destruct (decompose_stack π) in isr. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - destruct (isr _ wfΣ) as [isr']. + destruct (isr _ wfΣ) as [isr']. depelim isr'; rewrite mkApps_tApp in *; try solve [solve_discr]. apply whne_mkApps_inv in w; [|easy]. destruct w as [|(?&?&?&?&?&?&?&?)]; [|discriminate]. @@ -639,7 +639,7 @@ Section Conversion. rewrite <- H in rid, decompid, whid, isr; cbn in rid, decompid, whid, isr; clear H end. - + Lemma zipc_unfold_decompose_stack t π : zipc t π = zipc (mkApps t (decompose_stack π).1) (decompose_stack π).2. Proof using Type. @@ -714,9 +714,9 @@ Section Conversion. | [H: context[zipp ?t ?π] |- _] => rewrite (zipp_as_mkApps t π) in H | [|- context[zipp ?t ?π]] => rewrite (zipp_as_mkApps t π) end. - + Ltac simpl_reduce_stack Σ wfΣ := reduce_stack_facts Σ wfΣ ; simpl_stacks. - + (* Tailored view for isconv_prog and precondition for fallback case *) Equations prog_discr (t1 t2 : term) : Prop := prog_discr (tApp _ _) (tApp _ _) := False ; @@ -728,7 +728,7 @@ Section Conversion. prog_discr (tFix _ _) (tFix _ _) := False ; prog_discr (tCoFix _ _) (tCoFix _ _) := False ; prog_discr _ _ := True. - + (* Note that the arity of this should be the same for all s as otherwise the extracted code is not correct *) Definition Ret s Γ t π t' π' := @@ -787,7 +787,7 @@ Section Conversion. (repack (isconv_args_raw leq t1 π1 t2 π2 aux)) (only parsing). Notation isconv_fallback leq t1 π1 t2 π2 aux := (repack (isconv_fallback_raw leq t1 π1 t2 π2 aux)) (only parsing). - + Equations(noeqns) _isconv_red (Γ : context) (leq : conv_pb) (t1 : term) (π1 : stack) (h1 : wtp Γ t1 π1) (t2 : term) (π2 : stack) (h2 : wtp Γ t2 π2) @@ -799,7 +799,7 @@ Section Conversion. with inspect (decompose_stack π1) := { | @exist (args1, ρ1) e1 with inspect (decompose_stack π2) := { | @exist (args2, ρ2) e2 - with inspect (reduce_stack RedFlags.nodelta _ X + with inspect (reduce_stack RedFlags.nodelta _ X (Γ ,,, stack_context π1) t1 (appstack args1 []) _) := { | @exist (t1',π1') eq1 @@ -813,28 +813,28 @@ Section Conversion. }. Next Obligation. symmetry in e1. - pose proof (heΣ _ wfΣ); sq. - eapply welltyped_zipc_stack_context ; eauto. + pose proof (heΣ _ wfΣ); sq. + eapply welltyped_zipc_stack_context ; eauto. Qed. Next Obligation. clear aux eq1. symmetry in e2. - pose proof (heΣ _ wfΣ); sq. + pose proof (heΣ _ wfΣ); sq. now eapply welltyped_zipc_stack_context ; eauto. Qed. Next Obligation. simpl_reduce_stack Σ wfΣ. - pose proof (hΣ _ wfΣ); sq. + pose proof (hΣ _ wfΣ); sq. eapply red_welltyped ; try assumption ; revgoals. - zip fold. eapply red_context_zip. simpl_stacks. eapply r0. - cbn. simpl_stacks. eauto. Qed. Next Obligation. simpl_reduce_stack Σ wfΣ. - pose proof (hΣ _ wfΣ); sq. + pose proof (hΣ _ wfΣ); sq. eapply red_welltyped ; try assumption ; revgoals. - zip fold. eapply red_context_zip. simpl_stacks. eapply r. - - cbn. simpl_stacks. eauto. + - cbn. simpl_stacks. eauto. Qed. Next Obligation. match type of eq1 with @@ -882,7 +882,7 @@ Section Conversion. -- simpl. rewrite zipc_appstack. rewrite zipc_stack_cat. repeat zip fold. intros; eapply cored_context. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. * destruct y' as [q hq]. cbn in H0. inversion H0. subst. unshelve eapply R_positionR2. @@ -906,7 +906,7 @@ Section Conversion. eapply R_cored. simpl. rewrite zipc_appstack. rewrite zipc_stack_cat. repeat zip fold. intros; eapply cored_context. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + destruct y' as [q hq]. cbn in H0. inversion H0. (* Why is noconf failing at this point? *) subst. @@ -921,44 +921,44 @@ Section Conversion. rewrite stack_position_appstack. eapply positionR_poscat. assumption. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. rename H into wfΣ. simpl_reduce_stack Σ wfΣ. - eauto. + eauto. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; simpl_reduce_stack Σ wfΣ. specialize (isr0 eq_refl) as (?&?). split; [easy|]. - simpl_stacks. + simpl_stacks. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. eauto. + Unshelve. eauto. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; simpl_reduce_stack Σ wfΣ. specialize (isr eq_refl) as (?&?). split; [easy|]. simpl_stacks. - intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. eauto. + intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. eauto. Qed. Next Obligation. - rename H into wfΣ. + rename H into wfΣ. simpl_reduce_stack Σ wfΣ. destruct (hΣ _ wfΣ), (hx _ wfΣ). apply -> conv_cum_red_conv_iff; eauto. - eapply h; eauto. + eapply h; eauto. Qed. Next Obligation. - apply h; clear h. intros Σ wfΣ. + apply h; clear h. intros Σ wfΣ. simpl_reduce_stack Σ wfΣ. destruct (hΣ _ wfΣ), (hx _ wfΣ). apply <- conv_cum_red_conv_iff; eauto. - eapply H; eauto. + eapply H; eauto. Qed. Opaque reduce_stack. @@ -1193,10 +1193,10 @@ Section Conversion. reflexivity. Qed. - Lemma unfold_one_fix_None Γ mfix idx π wf : + Lemma unfold_one_fix_None Γ mfix idx π wf : None = unfold_one_fix Γ mfix idx π wf -> ∥∑args, - forall Σ (wfΣ : abstract_env_ext_rel X Σ), + forall Σ (wfΣ : abstract_env_ext_rel X Σ), All2 (red Σ (Γ,,, stack_context π)) (decompose_stack π).1 args × whnf RedFlags.default Σ (Γ,,, stack_context π) (mkApps (tFix mfix idx) args)∥. Proof using Type. @@ -1248,7 +1248,7 @@ Section Conversion. cbn in *; subst; cbn in *. destruct (hΣ Σ wfΣ), (wh Σ wfΣ). constructor; exists (l ++ (mkApps cred l0) :: (decompose_stack θ).1). - intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. eapply PCUICSR.subject_reduction in typ. 2: eauto. 2: apply red_mkApps; [reflexivity|]. @@ -1263,7 +1263,7 @@ Section Conversion. eauto. + eapply whnf_fix_arg_whne; eauto. now destruct cred. - Unshelve. eauto. + Unshelve. eauto. Qed. Inductive prog_view : term -> term -> Type := @@ -1325,15 +1325,15 @@ Section Conversion. welltyped Σ Γ t -> ∥ wf_local Σ Γ ∥. Proof using Type. - intros []; sq. - eapply typing_wf_local in X0; eauto. + intros []; sq. + eapply typing_wf_local in X0; eauto. Qed. Definition eqb_universe_instance_gen eq u v := forallb2 eq (map Universe.make u) (map Universe.make v). Definition eqb_universe_instance := - eqb_universe_instance_gen (abstract_env_eq X). + eqb_universe_instance_gen (abstract_env_eq X). Lemma eqb_universe_instance_spec : forall u v Σ (wfΣ : abstract_env_ext_rel X Σ), @@ -1347,17 +1347,17 @@ Section Conversion. eapply forallb2_Forall2 in e. eapply forallb_Forall in Hu. eapply forallb_Forall in Hv. - eapply Forall_Forall2_and in e; try exact Hu; clear Hu. - eapply Forall_Forall2_and' in e; try exact Hv; clear Hv. + eapply Forall_Forall2_and in e; try exact Hu; clear Hu. + eapply Forall_Forall2_and' in e; try exact Hv; clear Hv. eapply Forall2_impl. 1: eassumption. intros. cbn in H. destruct H as [[Hx H] Hy]. eapply (abstract_env_compare_universe_correct _ _ Conv); eauto; now eapply wf_universe_iff. - Unshelve. eauto. + Unshelve. eauto. Qed. - + Arguments LevelSet.mem : simpl never. - Definition abstract_conv_pb_relb `{cf : checker_flags} + Definition abstract_conv_pb_relb `{cf : checker_flags} (pb : conv_pb) := match pb with | Conv => abstract_env_eq X @@ -1375,11 +1375,11 @@ Section Conversion. destruct leq; eapply (abstract_env_compare_universe_correct _ _ _); eauto. Unshelve. all: eauto. Qed. - + Lemma get_level_make l : LevelExpr.get_level (LevelExpr.make l) = l. Proof using Type. now destruct l. Qed. - + Lemma compare_universeb_make_complete Σ (wfΣ : abstract_env_ext_rel X Σ) leq x y : wf_universe_level Σ x -> wf_universe_level Σ y -> @@ -1391,7 +1391,7 @@ Qed. - intros ? ->%LevelExprSet.singleton_spec; auto. - intros ? ->%LevelExprSet.singleton_spec; auto. Qed. - + Lemma eqb_universe_instance_complete Σ (wfΣ : abstract_env_ext_rel X Σ) u u' : wf_universe_instance Σ u -> wf_universe_instance Σ u' -> @@ -1409,8 +1409,8 @@ Qed. apply Bool.andb_true_iff. split. + eapply (compare_universeb_make_complete _ _ Conv); eauto. - + apply IHu; eauto. - Unshelve. all:eauto. + + apply IHu; eauto. + Unshelve. all:eauto. Qed. Lemma compare_universe_variance_complete Σ (wfΣ : abstract_env_ext_rel X Σ) leq v u u' : @@ -1423,7 +1423,7 @@ Qed. destruct v; cbn in *; eauto. - eapply compare_universeb_make_complete; eauto. - eapply (compare_universeb_make_complete _ _ Conv); eauto. - Unshelve. eauto. + Unshelve. eauto. Qed. Lemma compare_universe_instance_variance_complete Σ (wfΣ : abstract_env_ext_rel X Σ) leq v u u' : @@ -1459,7 +1459,7 @@ Qed. - eapply compare_universe_instance_variance_complete; eauto. - eapply eqb_universe_instance_complete; eauto. Qed. - + Lemma consistent_instance_ext_wf Σ udecl u : consistent_instance_ext Σ udecl u -> wf_universe_instance Σ u. @@ -1475,7 +1475,7 @@ Qed. cbn. intros ? ?%LevelSet.mem_spec; auto. Qed. - + Lemma welltyped_zipc_tConst_inv Σ (wfΣ : abstract_env_ext_rel X Σ) Γ c u π : welltyped Σ Γ (zipc (tConst c u) π) -> exists cst, @@ -1483,7 +1483,7 @@ Qed. × consistent_instance_ext Σ (cst_universes cst) u. Proof using Type. intros h. - zip fold in h. + zip fold in h. destruct (heΣ _ wfΣ). apply welltyped_context in h; auto. destruct h as (?&typ). @@ -1494,7 +1494,7 @@ Qed. Lemma red_conv_cum_l {leq Γ u v Σ}{wfΣ : abstract_env_ext_rel X Σ} : Σ ;;; Γ ⊢ u ⇝ v -> conv_cum leq Σ Γ u v. Proof using Type. - intros r. pose proof (hΣ _ wfΣ). sq. now apply red_ws_cumul_pb. + intros r. pose proof (hΣ _ wfΣ). sq. now apply red_ws_cumul_pb. Qed. Lemma red_conv_cum_r {leq Γ u v Σ}{wfΣ : abstract_env_ext_rel X Σ} : @@ -1514,7 +1514,7 @@ Qed. Qed. Ltac specialize_Σ wfΣ := - repeat match goal with | h : _ |- _ => specialize (h _ wfΣ) end. + repeat match goal with | h : _ |- _ => specialize (h _ wfΣ) end. Equations(noeqns) unfold_constants (Γ : context) (leq : conv_pb) (c : kername) (u : Instance.t) (π1 : stack) @@ -1539,7 +1539,7 @@ Qed. | @exist _ eq2 := no (NotFoundConstants c c') } }. -(* +(* Solve Obligations of unfold_constants with try destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; exfalso; @@ -1557,7 +1557,7 @@ Qed. unfold declared_constant in *; congruence end].*) - Ltac solve_unfold_constants aux eq1 eq2 Σ wfΣ := + Ltac solve_unfold_constants aux eq1 eq2 Σ wfΣ := try destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; exfalso; Tactics.program_simplify; @@ -1593,7 +1593,7 @@ Qed. rename H into wfΣ; destruct (hΣ _ wfΣ). etransitivity; try eauto. eapply red_conv_cum_r ; try assumption. - specialize (hx _ wfΣ). + specialize (hx _ wfΣ). eapply closed_red_zipp. * clear aux. eapply welltyped_zipc_zipp in h2; eauto. eapply welltyped_is_open_term in h2. @@ -1601,11 +1601,11 @@ Qed. * eapply into_closed_red; fvs. + eapply red_const. erewrite abstract_env_lookup_correct; eauto. + red in h. sq. fvs. - Unshelve. eauto. + Unshelve. eauto. Qed. Next Obligation. (* Contraposition of previous goal *) - apply h; clear h. intros Σ wfΣ. + apply h; clear h. intros Σ wfΣ. destruct (hΣ _ wfΣ). etransitivity ; try eauto. specialize (hx _ wfΣ). @@ -1616,8 +1616,8 @@ Qed. * eapply into_closed_red; fvs. + eapply red_const. erewrite abstract_env_lookup_correct; eauto. + sq. fvs. - Unshelve. eauto. - Qed. + Unshelve. eauto. + Qed. Next Obligation. pose proof (hΣ _ wfΣ). sq. eapply red_welltyped ; [eauto|exact (h1 _ wfΣ)|..]. @@ -1636,12 +1636,12 @@ Qed. { eapply welltyped_zipc_zipp in h1; auto; fvs. } eapply into_closed_red; fvs. + eapply red_const. erewrite abstract_env_lookup_correct; eauto. - + specialize (hx _ wfΣ). clear -hx wΣ. sq. fvs. - Unshelve. all : eauto. - Qed. + + specialize (hx _ wfΣ). clear -hx wΣ. sq. fvs. + Unshelve. all : eauto. + Qed. Next Obligation. (* Contraposition of previous goal *) - apply h; clear h. intros Σ wfΣ. + apply h; clear h. intros Σ wfΣ. destruct (hΣ _ wfΣ) as [wΣ]. etransitivity ; try eauto. eapply red_conv_cum_r ; try assumption. @@ -1649,9 +1649,9 @@ Qed. { eapply welltyped_zipc_zipp in h1; auto; fvs. } eapply into_closed_red; fvs. + eapply red_const. erewrite abstract_env_lookup_correct; eauto. - + specialize (hx _ wfΣ). sq; fvs. - Unshelve. eauto. - Qed. + + specialize (hx _ wfΣ). sq; fvs. + Unshelve. eauto. + Qed. Next Obligation. (* Both c and c' are axioms. Either they are different constants or they are not convertible because the universes are different. *) @@ -1660,41 +1660,41 @@ Qed. apply conv_cum_alt in H as [(?&?&[r1 r2 eq])]; auto. 2: pose proof (hΣ _ wfΣ); sq ; eauto. rewrite zipp_as_mkApps in r1, r2. - erewrite <- abstract_env_lookup_correct in eq1, eq2; eauto. + erewrite <- abstract_env_lookup_correct in eq1, eq2; eauto. symmetry in eq1, eq2. - generalize hΣ. intros []; eauto. + generalize hΣ. intros []; eauto. unshelve eapply closed_red_mkApps_tConst_axiom in r1 as (?&->&?); eauto. eapply closed_red_mkApps_tConst_axiom in r2 as (?&->&?); eauto. apply eq_termp_mkApps_inv in eq as (eq&?); [|easy|easy]. depelim eq. destruct ne as [|(_&ne)]; [congruence|]. - - clear aux. specialize (h1 _ wfΣ). specialize (h2 _ wfΣ). - apply welltyped_zipc_tConst_inv in h1 as (cst1&decl1&cons1); eauto. - apply welltyped_zipc_tConst_inv in h2 as (cst2&decl2&cons2); eauto. + + clear aux. specialize (h1 _ wfΣ). specialize (h2 _ wfΣ). + apply welltyped_zipc_tConst_inv in h1 as (cst1&decl1&cons1); eauto. + apply welltyped_zipc_tConst_inv in h2 as (cst2&decl2&cons2); eauto. eapply declared_constant_inj in decl1; eauto; subst. apply consistent_instance_ext_wf in cons1. apply consistent_instance_ext_wf in cons2. eapply eqb_universe_instance_complete in r; auto. Qed. (* Why Solve All Obligations is not working here ??? *) - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ H. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ H. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. - + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ H. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ H. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Qed. + Lemma welltyped_zipc_tCase_brs_length Σ (wfΣ : abstract_env_ext_rel X Σ) Γ ci motive discr brs π : welltyped Σ Γ (zipc (tCase ci motive discr brs) π) -> exists mib oib, declared_inductive Σ ci mib oib /\ #|brs| = #|ind_ctors oib|. @@ -1709,7 +1709,7 @@ Qed. split; [easy|]. now apply All2i_length in brs_ty. Qed. - + Equations (noeqns) isconv_context_aux (Γ Γ' Δ Δ' : context) (cc : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥Σ ⊢ Γ = Γ'∥) @@ -1739,7 +1739,7 @@ Qed. | Success conv_rest with inspect (eqb_binder_annot na na') := { - + | exist false neq_binders => no (ContextNotConvertibleAnn (Γ,,, Δpre) (mkdecl na bd ty) (Γ',,, Δ'pre) (mkdecl na' bd' ty')); @@ -1755,7 +1755,7 @@ Qed. (Γ',,, Δ'pre) (mkdecl na' bd' ty')); | Success conv_type with bd, bd' := { - + | Some body | Some body' with check Conv (Δpre, decl_hole_body na ty, Δpost) body @@ -1764,7 +1764,7 @@ Qed. | Error ce not_conv_body => no (ContextNotConvertibleBody (Γ,,, Δpre) (mkdecl na bd ty) (Γ',,, Δ'pre) (mkdecl na' bd' ty')); - + | Success conv_body => yes }; @@ -1781,18 +1781,18 @@ Qed. isconv_context_aux Γ Γ' Δ Δ' cc check Δpre Δ'pre Δpost Δ'post eq eq' => no ContextNotConvertibleLength }. - Next Obligation. - pose proof (heΣ _ wfΣ). specialize (cc _ wfΣ). sq. - constructor; fvs. + Next Obligation. + pose proof (heΣ _ wfΣ). specialize (cc _ wfΣ). sq. + constructor; fvs. - constructor. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (hΣ _ wfΣ). specialize (H _ wfΣ). sq. depelim H. depelim a. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (hΣ _ wfΣ). specialize (H _ wfΣ). sq. destruct H as [H]; depelim H. depelim a. Qed. @@ -1805,60 +1805,60 @@ Qed. rewrite <- app_assoc; auto. Qed. Next Obligation. - unfold conv_cum in conv_type, conv_body. - pose proof (hΣ _ wfΣ). specialize_Σ wfΣ. + unfold conv_cum in conv_type, conv_body. + pose proof (hΣ _ wfΣ). specialize_Σ wfΣ. sq. constructor; fvs. - constructor; auto. + constructor; auto. * now destruct conv_rest. * constructor; auto. apply eqb_annot_spec; auto. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (hΣ _ wfΣ). specialize (H _ wfΣ). sq. destruct H as [H]. contradiction not_conv_body. depelim H. - depelim a. depelim a0. intros. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + depelim a. depelim a0. intros. + erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. constructor; auto. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (hΣ _ wfΣ). specialize (H _ wfΣ). sq. destruct H as [H]. depelim H. depelim a. depelim a0. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (hΣ _ wfΣ). specialize (H _ wfΣ). sq. destruct H as [H]. - depelim H. + depelim H. depelim a. depelim a0. Qed. Next Obligation. red in conv_type. pose proof (hΣ _ wfΣ). specialize_Σ wfΣ. sq. constructor; fvs. - constructor; auto. + constructor; auto. * now destruct conv_rest. * constructor; auto. apply eqb_annot_spec; auto. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (hΣ _ wfΣ). specialize (H _ wfΣ). sq. destruct H as [H]. contradiction not_conv_type. - depelim H. intros. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + depelim H. intros. + erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. constructor. - depelim a; auto. depelim a0; eauto. - Unshelve. all: eauto. + depelim a; auto. depelim a0; eauto. + Unshelve. all: eauto. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (hΣ _ wfΣ). specialize (H _ wfΣ). sq. destruct H as [H]. depelim H. @@ -1867,16 +1867,16 @@ Qed. - apply eqb_annot_spec in eqna; congruence. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (hΣ _ wfΣ). specialize (H _ wfΣ). sq. destruct H as [H]. contradiction not_conv_rest. depelim H. - depelim a. intros. + depelim a. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - constructor; auto. + constructor; auto. split; auto. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Definition isconv_context @@ -1908,7 +1908,7 @@ Qed. test_context_k (fun k : nat => on_free_vars (closedP k (fun _ : nat => true))) #|pparams p'| br'.(bcontext)] ∥. Proof using Type. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (hΣ _ wfΣ) as [hΣ]. specialize_Σ wfΣ. destruct hx as [hx]. destruct hp as [hp]. @@ -1919,7 +1919,7 @@ Qed. destruct h as [s h]. destruct h' as [s' h']. eapply PCUICValidity.inversion_mkApps in h as [A [hcase _]]. eapply PCUICValidity.inversion_mkApps in h' as [A' [hcase' _]]. - destruct hp as []. + destruct hp as []. eapply inversion_Case in hcase as [mdecl [idecl [decli [indices [hcase _]]]]]; auto. eapply inversion_Case in hcase' as [mdecl' [idecl' [decli' [indices' [hcase' _]]]]]; auto. destruct (declared_inductive_inj decli decli'). subst mdecl' idecl'. @@ -1952,12 +1952,12 @@ Qed. eapply All2i_app_inv_r in brs_ty as (? & ? & ? & ? & ?). depelim a3. eapply All2i_length in a2. clear a3. destruct p1 as [p1 _]. - rewrite e in e0. cbn in *. + rewrite e in e0. cbn in *. pose proof (All2_length h1). rewrite <- a1 in H. rewrite <- a2 in H. eapply app_inj_length_l in e0 as [-> eq]; auto. noconf eq. exists mdecl, idecl. split; tea. - - intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + - intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - eapply (wf_predicate_length_pars wf_pred). - eapply (wf_predicate_length_pars wf_pred0). - eapply alpha_eq_context_gen. etransitivity; tea. @@ -1972,7 +1972,7 @@ Qed. now rewrite Nat.sub_diag; cbn. } rewrite (wf_predicate_length_pars wf_pred). now rewrite (PCUICGlobalEnv.declared_minductive_ind_npars decli). - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. @@ -2016,12 +2016,12 @@ Qed. constructor. constructor. Qed. Next Obligation. - clear aux. + clear aux. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. destruct h1 as [h1]. apply All2_length in h1 as e1. - apply welltyped_zipc_tCase_brs_length in h as (?&?&?&?); eauto. + apply welltyped_zipc_tCase_brs_length in h as (?&?&?&?); eauto. apply welltyped_zipc_tCase_brs_length in h' as (?&?&?&?); eauto. pose proof (PCUICInductiveInversion.declared_inductive_unique_sig H H1) as u; noconf u. rewrite app_length in *. @@ -2029,12 +2029,12 @@ Qed. lia. Qed. Next Obligation. - clear aux. + clear aux. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. destruct h1 as [h1]. apply All2_length in h1 as e1. - apply welltyped_zipc_tCase_brs_length in h as (?&?&?&?); eauto. + apply welltyped_zipc_tCase_brs_length in h as (?&?&?&?); eauto. apply welltyped_zipc_tCase_brs_length in h' as (?&?&?&?); eauto. pose proof (PCUICInductiveInversion.declared_inductive_unique_sig H H1) as u; noconf u. rewrite app_length in *. @@ -2050,14 +2050,14 @@ Qed. constructor. Qed. Next Obligation. - eapply case_conv_brs_inv in h1; tea. + eapply case_conv_brs_inv in h1; tea. rename H into wfΣ; pose proof (hΣ _ wfΣ). specialize_Σ wfΣ. sq. destruct h1 as [mdecl [idecl [decli eqp eqp' eqm clm clm']]]. transitivity (Γ ,,, stack_context π ,,, inst_case_context (pparams p') (puinst p') m'). - unfold app_context; rewrite <-app_assoc. - inv_on_free_vars. - eapply inst_case_ws_cumul_ctx_pb; tea. + inv_on_free_vars. + eapply inst_case_ws_cumul_ctx_pb; tea. * fvs. * fvs. * eapply hp. @@ -2085,7 +2085,7 @@ Qed. 2: now constructor. simpl. unfold zipp in h2. - split; auto. + split; auto. cbn in h2. unfold inst_case_branch_context. cbn. now unfold app_context; rewrite app_assoc. @@ -2093,12 +2093,12 @@ Qed. Next Obligation. clear aux. unfold isconv_branches_obligations_obligation_13. eapply R_irrelevance. 2:tea. cbn. - f_equal. f_equal. 2:{ f_equal. now rewrite <-app_assoc. } + f_equal. f_equal. 2:{ f_equal. now rewrite <-app_assoc. } f_equal. f_equal. f_equal. now rewrite <- app_assoc. - Qed. + Qed. Next Obligation. destruct (case_conv_brs_inv h p' c' brs1' brs2' _ h') as [[mdecl [idecl [decli eqp eqp' eqm clm clm']]]]; tea. - specialize_Σ wfΣ. + specialize_Σ wfΣ. destruct h2 as [h2], h3 as [h3]. constructor. constructor; auto. @@ -2108,7 +2108,7 @@ Qed. Qed. Next Obligation. (* Contrapositive of previous obligation *) - apply h''; clear h''. intros. specialize_Σ wfΣ. + apply h''; clear h''. intros. specialize_Σ wfΣ. destruct H as [H]; inversion H; now constructor. Qed. Next Obligation. @@ -2119,7 +2119,7 @@ Qed. destruct X0 as [_ h2]. simpl in h2. cbn. now rewrite app_context_assoc. Qed. - + Equations isconv_branches' (Γ : context) (ci : case_info) (p : predicate term) (c : term) (brs : list (branch term)) @@ -2149,7 +2149,7 @@ Qed. | IndFix => tFix | CoIndFix => tCoFix end. - + Definition mFix_mfix fk := match fk with | IndFix => Fix @@ -2241,7 +2241,7 @@ Qed. Next Obligation. (* Right list is empty *) destruct H as [H]; inversion H. - Qed. + Qed. Next Obligation. destruct u. destruct fk. all: eauto. Qed. @@ -2282,7 +2282,7 @@ Qed. split; auto. destruct fk; simpl in *; auto. all: intros; erewrite (abstract_env_ext_irr _ _ wfΣ); intuition eauto. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. clear aux. @@ -2304,20 +2304,20 @@ Qed. clear eq1. destruct fk. all: split; [ intros; erewrite (abstract_env_ext_irr _ _ wfΣ) | ]; intuition eauto . - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. (* Contrapositive of previous obligation *) apply h''; clear h''. destruct H as [H]; inversion H. constructor; assumption. - Qed. + Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. destruct H as [H]; inversion H; destruct X0 as [eq_uv _]. apply h''; clear h''; constructor. - destruct fk; apply eq_uv; eauto. + destruct fk; apply eq_uv; eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. @@ -2446,7 +2446,7 @@ Qed. revert hx ha. generalize (Γ ,,, stack_context π'). generalize (Γ ,,, stack_context π). - clear Γ. intros Γ Γ' hx ha. + clear Γ. intros Γ Γ' hx ha. assert (h : All2 (fun d d' => (Σ ;;; Γ ⊢ d.2 = d'.2) * eq_binder_annot d.1 d'.1) @@ -2500,7 +2500,7 @@ Qed. set (ln := #|Δ|) in *. set (m := 0) in *. assert (e : ln - m = #|Δ|) by lia. - clearbody ln m. + clearbody ln m. induction h. - eauto. - simpl in *. @@ -2508,8 +2508,8 @@ Qed. constructor. + eapply IHh. + eapply r0. 2:lia. - clear - wΣ IHh. fvs. - Qed. + clear - wΣ IHh. fvs. + Qed. Next Obligation. rewrite <- app_assoc. simpl. eauto. Qed. @@ -2536,11 +2536,11 @@ Qed. destruct u as [na ty bo ra], v as [na' ty' bo' ra']. simpl in *. unfold def_sig at 2. simpl. destruct fk. - + intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + + intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. rewrite app_context_assoc in h2; eauto. - + intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + + intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. rewrite app_context_assoc in h2; eauto. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. @@ -2565,9 +2565,9 @@ Qed. - destruct u as [na ty bo ra], v as [na' ty' bo' ra']. simpl in *. unfold def_sig at 2. simpl. destruct fk. - + intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + + intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. rewrite app_context_assoc in h2; eauto. - + intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + + intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. rewrite app_context_assoc in h2; eauto. - eapply All2_impl. 1: exact h3. @@ -2576,19 +2576,19 @@ Qed. rewrite map_app in hh. simpl in hh. rewrite <- !app_assoc in hh. simpl in hh. assumption. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. apply h''; clear h''. destruct H as [H]; inversion H; constructor. rewrite map_app, <- app_assoc; simpl; assumption. - Qed. + Qed. Next Obligation. apply h''; clear h''. destruct H as [H]; inversion H; constructor. destruct fk; cbn -[app_context]. - all: rewrite app_context_assoc; apply X0; eauto. - Qed. + all: rewrite app_context_assoc; apply X0; eauto. + Qed. Equations isws_cumul_pb_Fix (fk : fix_kind) (Γ : context) (mfix : mfixpoint term) (idx : nat) (π : stack) @@ -2639,14 +2639,14 @@ Qed. destruct H as [H]; constructor. apply (All2_impl H). rewrite <- fix_context_fix_context_alt. intuition. - Qed. + Qed. Next Obligation. (* Contrapositive of pre-previous obligation *) apply h''; clear h''. destruct H as [H]; constructor; apply (All2_impl H). intuition. Qed. - + Lemma invert_type_mkApps_tProd Σ (wfΣ : abstract_env_ext_rel X Σ) Γ na A b args T : Σ;;; Γ |- mkApps (tProd na A b) args : T -> args = []. Proof using Type. @@ -2687,13 +2687,13 @@ Qed. isred_full Γ (tCase ci p c brs) π -> ∥whne RedFlags.default Σ (Γ,,, stack_context π) c∥. Proof using Type. - intros eq ir. pose proof (heΣ _ wfΣ) as [[]]. - pose proof (hΣ _ wfΣ). - destruct ir as (_&[wh]); eauto. + intros eq ir. pose proof (heΣ _ wfΣ) as [[]]. + pose proof (hΣ _ wfΣ). + destruct ir as (_&[wh]); eauto. eapply eqb_term_upto_univ_impl with (p := wf_universeb Σ) (q := closedu) in eq; tea. - 2-3: intros; apply iff_reflect; eapply (abstract_env_compare_universe_correct _ wfΣ Conv) ; now eapply wf_universe_iff. - 2:{ intros. rewrite wf_universeb_instance_forall in *. - apply wf_universe_instance_iff in H0. + 2-3: intros; apply iff_reflect; eapply (abstract_env_compare_universe_correct _ wfΣ Conv) ; now eapply wf_universe_iff. + 2:{ intros. rewrite wf_universeb_instance_forall in *. + apply wf_universe_instance_iff in H0. apply wf_universe_instance_iff in H1. eapply (abstract_env_compare_global_instance_correct X wfΣ); eauto. intros. apply X0; now eapply wf_universe_iff. } @@ -2703,18 +2703,18 @@ Qed. depelim wh; solve_discr. apply whne_mkApps_inv in w as [|(?&?&?&?&?&?&?&?&?)]; [|easy|easy]. depelim w; cbn in *; try easy; solve_discr. - apply whnf_whne_nodelta_upgrade in eq; auto using sq. + apply whnf_whne_nodelta_upgrade in eq; auto using sq. - pose proof (reduce_term_sound RedFlags.default X_type X (Γ,,, stack_context π) c h) as Hreduce. - specialize_Σ wfΣ. pose proof (h _ wfΣ) as [C hc]. sq. - apply closed_red_red in Hreduce. eapply PCUICSR.subject_reduction in hc; eauto. + specialize_Σ wfΣ. pose proof (h _ wfΣ) as [C hc]. sq. + apply closed_red_red in Hreduce. eapply PCUICSR.subject_reduction in hc; eauto. Opaque reduce_term. - eapply typing_wf_universes in hc as [? ?]%andb_and; eauto. + eapply typing_wf_universes in hc as [? ?]%andb_and; eauto. - clear eq. specialize_Σ wfΣ. sq. destruct h as [? h]. - eapply typing_wf_universes in h as [h h']%andb_and; eauto. - Unshelve. all:eauto. + eapply typing_wf_universes in h as [h h']%andb_and; eauto. + Unshelve. all:eauto. Qed. - Lemma welltyped_zipp_inv Σ Γ t π : + Lemma welltyped_zipp_inv Σ Γ t π : wf Σ -> welltyped Σ Γ (zipp t π) -> welltyped Σ Γ t. Proof using Type. induction π; cbn; auto. @@ -2727,15 +2727,15 @@ Qed. Lemma welltyped_zipc_inv Σ Γ t π : wf Σ -> welltyped Σ Γ (zipc t π) -> welltyped Σ (Γ,,, stack_context π) t. Proof. - intros ? Ht. apply welltyped_zipc_zipp in Ht; eauto. - apply welltyped_zipp_inv in Ht; eauto. - Defined. + intros ? Ht. apply welltyped_zipc_zipp in Ht; eauto. + apply welltyped_zipp_inv in Ht; eauto. + Defined. Lemma welltyped_wf Σ Γ t : wf Σ -> welltyped Σ Γ t -> wf_universes Σ t. - Proof using Type. + Proof using Type. intros ? [? Ht]. apply typing_wf_universes in Ht; eauto. cbn in Ht. rtoProp; intuition. - Qed. + Qed. Lemma inv_reduced_discriminees_case Σ (wfΣ : abstract_env_ext_rel X Σ) leq Γ π π' ci ci' p p' c c' brs brs' h h' : conv_stack_ctx Γ π π' -> @@ -2759,7 +2759,7 @@ Qed. ws_cumul_pb_brs Σ (Γ,,, stack_context π) p brs brs' & ws_cumul_pb_terms Σ (Γ,,, stack_context π) (decompose_stack π).1 (decompose_stack π').1]∥. Proof using Type. - intros [] c_is_red%eq_sym c'_is_red%eq_sym wtc wtc' isr1 isr2 cc; eauto. + intros [] c_is_red%eq_sym c'_is_red%eq_sym wtc wtc' isr1 isr2 cc; eauto. eapply reduced_case_discriminee_whne in c_is_red as wh1; eauto. eapply reduced_case_discriminee_whne in c'_is_red as wh2; eauto. destruct (hΣ _ wfΣ) as [hΣ], wh1 as [wh1], wh2 as [wh2]. @@ -2768,10 +2768,10 @@ Qed. 2:{ symmetry in X0. eapply ws_cumul_ctx_pb_forget in X0. exact X0. } apply conv_cum_mkApps_inv in cc as [(ws_cumul_pb_Case&conv_args)]; eauto using whnf_mkApps. red in isr1. - eapply welltyped_zipc_zipp, welltyped_zipp_inv in wtc; eauto. + eapply welltyped_zipc_zipp, welltyped_zipp_inv in wtc; eauto. eapply welltyped_zipc_zipp, welltyped_zipp_inv in wtc'; eauto. destruct wtc. eapply inversion_Case in X1 as [mdecl [idecl [isdecl [indices [[] ?]]]]]; tea. - destruct wtc'. eapply inversion_Case in X1 as [mdecl' [idecl' [isdecl' [indices' [[] ?]]]]] ; tea; eauto. + destruct wtc'. eapply inversion_Case in X1 as [mdecl' [idecl' [isdecl' [indices' [[] ?]]]]] ; tea; eauto. eapply conv_cum_tCase_inv in ws_cumul_pb_Case; eauto. destruct ws_cumul_pb_Case as [[<- ? ? ?]]. split; split; auto. @@ -2785,13 +2785,13 @@ Qed. ∥whne RedFlags.default Σ (Γ,,, stack_context π) c∥. Proof using Type. intros eq%eq_sym ir. - destruct ir as (_&[wh]); eauto. - pose proof (hΣ _ wfΣ). + destruct ir as (_&[wh]); eauto. + pose proof (hΣ _ wfΣ). eapply eqb_term_upto_univ_impl in eq; tea. - 2-3: intros; apply iff_reflect; eapply (abstract_env_compare_universe_correct _ wfΣ Conv) ; now eapply wf_universe_iff. - 2:{ intros. rewrite wf_universeb_instance_forall in *. - apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. + 2-3: intros; apply iff_reflect; eapply (abstract_env_compare_universe_correct _ wfΣ Conv) ; now eapply wf_universe_iff. + 2:{ intros. rewrite wf_universeb_instance_forall in *. + apply wf_universe_instance_iff in H0. + apply wf_universe_instance_iff in H1. eapply (abstract_env_compare_global_instance_correct X wfΣ); eauto. intros. apply X0; now eapply wf_universe_iff. } - epose proof (reduce_term_complete _ _ _ _ _ _) as [wh']. @@ -2802,15 +2802,15 @@ Qed. depelim w; cbn in *; try easy; solve_discr. apply whnf_whne_nodelta_upgrade in eq; auto using sq. - pose proof (reduce_term_sound RedFlags.default X_type X (Γ,,, stack_context π) c h) as Hreduce. - specialize_Σ wfΣ. pose proof (h _ wfΣ) as [C hc]. sq. - apply closed_red_red in Hreduce. eapply PCUICSR.subject_reduction in hc; eauto. + specialize_Σ wfΣ. pose proof (h _ wfΣ) as [C hc]. sq. + apply closed_red_red in Hreduce. eapply PCUICSR.subject_reduction in hc; eauto. Opaque reduce_term. - eapply typing_wf_universes in hc as [? ?]%andb_and; eauto. + eapply typing_wf_universes in hc as [? ?]%andb_and; eauto. - clear eq. specialize_Σ wfΣ. sq. destruct h as [? h]. - eapply typing_wf_universes in h as [h h']%andb_and; eauto. - Unshelve. all:eauto. + eapply typing_wf_universes in h as [h h']%andb_and; eauto. + Unshelve. all:eauto. Qed. - + Lemma inv_reduced_body_proj Σ (wfΣ : abstract_env_ext_rel X Σ) leq Γ π π' p p' c c' h h' : conv_stack_ctx Γ π π' -> true = eqb_term (reduce_term @@ -2838,7 +2838,7 @@ Qed. destruct conv_proj as [(<-&?)]. constructor; auto. Qed. - + Lemma conv_cum_red_conv_inv Σ (wfΣ : abstract_env_ext_rel X Σ) leq Γ Γ' t1 t2 t1' t2' : ws_cumul_ctx_pb Conv Σ Γ Γ' -> red Σ Γ t1 t1' -> @@ -2848,9 +2848,9 @@ Qed. Proof using Type. intros. destruct (hΣ _ wfΣ) as [wΣ]. eapply conv_cum_red_conv_inv; eauto. - all:eapply into_closed_red; tea. + all:eapply into_closed_red; tea. * fvs. - * destruct H; fvs. + * destruct H; fvs. * fvs. * destruct H. rewrite <-(All2_fold_length X0). now eapply ws_cumul_pb_is_open_term_right. Qed. @@ -2868,23 +2868,23 @@ Qed. mfix mfix' & ws_cumul_pb_terms Σ (Γ,,, stack_context π) (decompose_stack π).1 (decompose_stack π').1]∥. Proof using Type. - intros [?] uf1 uf2 cc; eauto. + intros [?] uf1 uf2 cc; eauto. rewrite !zipp_as_mkApps in cc; eauto. - apply unfold_one_fix_None in uf1. - destruct uf1 as [(?&?&?)]; eauto. + apply unfold_one_fix_None in uf1. + destruct uf1 as [(?&?&?)]; eauto. apply unfold_one_fix_None in uf2. destruct uf2 as [(?&?&?)]; eauto. destruct (hΣ _ wfΣ). eapply conv_cum_red_conv_inv in cc. 2: eassumption. - 2: exact X0. + 2: exact X0. 2: eapply red_mkApps; [reflexivity|exact a]. 2: apply red_mkApps; [reflexivity|exact a0]. apply conv_cum_mkApps_inv in cc as [(ws_cumul_pb_Fix&conv_args)]; auto. 2:{ eapply whnf_conv_context; eauto. symmetry in X0. now eapply ws_cumul_ctx_pb_forget in X0. } apply conv_cum_tFix_inv in ws_cumul_pb_Fix as [(<-&?)]; auto. - sq; split; auto. + sq; split; auto. * eapply All2_impl; tea; cbn. intros ? ? []. repeat split; auto. * eapply ws_cumul_pb_terms_red_conv; eauto. all:eapply into_red_terms; tea. @@ -2920,7 +2920,7 @@ Qed. constructor; split; [|split]; auto. eapply All2_impl; tea. intros ? ? []. repeat split; auto. Qed. - + Equations (noeqns) isconv_predicate_params_aux (Γ : context) (ci1 : case_info) @@ -2939,7 +2939,7 @@ Qed. isconv_predicate_params_aux Γ ci1 p1 c1 brs1 π1 h1 ci2 p2 c2 brs2 π2 h2 hx aux pre1 pre2 [] [] eq1 eq2 => yes; - + isconv_predicate_params_aux Γ ci1 p1 c1 brs1 π1 h1 ci2 p2 c2 brs2 π2 h2 hx aux pre1 pre2 (t1 :: post1) (t2 :: post2) eq1 eq2 @@ -2953,16 +2953,16 @@ Qed. ci2 (pred_hole_params pre2 post2 p2.(puinst) p2.(pcontext) p2.(preturn)) c2 brs2 :: π2) aux := { - + | Error ce not_conv_term => no ce; | Success conv_tm with isconv_predicate_params_aux Γ ci1 p1 c1 brs1 π1 h1 ci2 p2 c2 brs2 π2 h2 hx aux (pre1 ++ [t1]) (pre2 ++ [t2]) post1 post2 _ _ := { - + | Error ce not_conv_rest => no ce; - + | Success conv_rest => yes } }; @@ -2973,14 +2973,14 @@ Qed. (Γ,,, stack_context π1) ci1 p1 c1 brs1 (Γ,,, stack_context π2) ci2 p2 c2 brs2). Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; - specialize_Σ wfΣ. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + specialize_Σ wfΣ. destruct H as [H]. depelim H. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; - specialize_Σ wfΣ. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + specialize_Σ wfΣ. destruct H as [H]. depelim H. Qed. @@ -3005,27 +3005,27 @@ Qed. rewrite <- app_assoc; auto. Qed. Next Obligation. - specialize_Σ wfΣ. + specialize_Σ wfΣ. destruct conv_tm, conv_rest. unfold zipp in X; simpl in *. constructor; constructor; auto. Qed. Next Obligation. - contradiction not_conv_rest. intros. - specialize_Σ wfΣ. + contradiction not_conv_rest. intros. + specialize_Σ wfΣ. destruct H as [H]; depelim H. constructor; auto. Qed. Next Obligation. - contradiction not_conv_term. intros Σ wfΣ. - specialize_Σ wfΣ. + contradiction not_conv_term. intros Σ wfΣ. + specialize_Σ wfΣ. destruct H as [H]; depelim H. constructor; auto. Qed. Lemma case_conv_preds_inv Σ (wfΣ : abstract_env_ext_rel X Σ) {Γ ci p c brs brs' π} (h : wtp Γ (tCase ci p c brs) π) - (p' : predicate term) (c' : term) + (p' : predicate term) (c' : term) (π' : stack) (h' : wtp Γ (tCase ci p' c' brs') π') (hx : conv_stack_ctx Γ π π') (hp : ∥ ws_cumul_pb_terms Σ (Γ,,, stack_context π) (pparams p) (pparams p') ∥) : @@ -3072,15 +3072,15 @@ Qed. destruct hcase. destruct hcase'. split; tea. - eapply Forall_forallb; try eapply consistent_instance_wf_universe; eauto. - intros; apply wf_universe_iff; eauto. + intros; apply wf_universe_iff; eauto. - eapply Forall_forallb; try eapply consistent_instance_wf_universe; eauto. - intros; apply wf_universe_iff; eauto. + intros; apply wf_universe_iff; eauto. - eapply (wf_predicate_length_pars wf_pred). - eapply (wf_predicate_length_pars wf_pred0). - eapply alpha_eq_context_gen. etransitivity; tea. - now symmetry. + now symmetry. - now rewrite <- test_context_k_closed_on_free_vars_ctx. - - rewrite test_context_k_closed_on_free_vars_ctx. + - rewrite test_context_k_closed_on_free_vars_ctx. eapply PCUICConfluence.eq_context_upto_names_on_free_vars. 2:symmetry; exact conv_pctx0. rewrite <- closedn_ctx_on_free_vars. @@ -3093,11 +3093,11 @@ Qed. Definition forallb2_proper A B (R R' : A -> B -> bool) l l': (forall a b, R a b = R' a b) -> - forallb2 R l l' = + forallb2 R l l' = forallb2 R' l l'. Proof using Type. intro e. revert l'. - induction l; destruct l'; eauto. + induction l; destruct l'; eauto. cbn; intros. rewrite <- e. apply eq_true_iff_eq. split; intros. all: apply andb_and; now apply andb_and in H. @@ -3116,7 +3116,7 @@ Qed. (aux : Aux Term Γ (tCase ci1 p1 c1 brs1) π1 (tCase ci2 p2 c2 brs2) π2 h2) := isconv_predicate_params_aux Γ ci1 p1 c1 brs1 π1 h1 ci2 p2 c2 brs2 π2 h2 hx aux [] [] p1.(pparams) p2.(pparams) eq_refl eq_refl. - + Equations (noeqns) isconv_predicate (Γ : context) (ci1 : case_info) @@ -3176,8 +3176,8 @@ Qed. Qed. Next Obligation. rename H into wfΣ. - destruct (hΣ _ wfΣ). - eapply eq_sym, eqb_universe_instance_spec in eq_insts; eauto. + destruct (hΣ _ wfΣ). + eapply eq_sym, eqb_universe_instance_spec in eq_insts; eauto. - destruct (case_conv_preds_inv _ wfΣ h1 _ _ _ h2 hx (conv_params _ wfΣ)) as []; tea. specialize_Σ wfΣ. destruct hx as [hx]. destruct conv_params as [conv_params]. @@ -3188,18 +3188,18 @@ Qed. * inv_on_free_vars. eapply (inst_case_ws_cumul_ctx_pb d e e0 i1 i2); tea. fvs. * eapply ws_cumul_ctx_pb_app_same. 2:eapply hx. rewrite on_free_vars_ctx_app. - apply andb_true_iff. split; auto. + apply andb_true_iff. split; auto. 1:now eapply ws_cumul_ctx_pb_closed_left in hx. eapply on_free_vars_ctx_inst_case_context; trea. fvs. - destruct (case_conv_preds_inv _ wfΣ h1 _ _ _ h2 hx (conv_params Σ wfΣ)) as []; tea. - destruct X1 as [mdecl [idecl []]]. eauto. + destruct X1 as [mdecl [idecl []]]. eauto. - destruct (case_conv_preds_inv _ wfΣ h1 _ _ _ h2 hx (conv_params Σ wfΣ)) as []; tea. - destruct X1 as [mdecl [idecl []]]. eauto. + destruct X1 as [mdecl [idecl []]]. eauto. Qed. Next Obligation. unfold zipp in conv_ret; simpl in conv_ret. - destruct (case_conv_preds_inv _ wfΣ h1 _ _ _ h2 hx (conv_params Σ wfΣ)) as []; tea. + destruct (case_conv_preds_inv _ wfΣ h1 _ _ _ h2 hx (conv_params Σ wfΣ)) as []; tea. eapply eq_sym, eqb_universe_instance_spec in eq_insts; eauto. - specialize_Σ wfΣ. destruct hx as [hx]. destruct conv_params as [conv_params]. destruct conv_ret as [h]. @@ -3212,7 +3212,7 @@ Qed. Next Obligation. unfold zipp in not_conv_ret; simpl in not_conv_ret. contradiction not_conv_ret. - rewrite app_context_assoc. intros Σ wfΣ. specialize_Σ wfΣ. + rewrite app_context_assoc. intros Σ wfΣ. specialize_Σ wfΣ. destruct H as [[]]; constructor; auto. Qed. Next Obligation. @@ -3234,7 +3234,7 @@ Qed. Qed. Next Obligation. contradiction not_conv_params. intros Σ wfΣ. - specialize_Σ wfΣ. + specialize_Σ wfΣ. destruct H as [[]]; constructor; auto. Qed. @@ -3249,7 +3249,7 @@ Qed. all:eapply into_closed_red; tea; fvs. Qed. - + (* See https://github.com/coq/coq/blob/master/kernel/reduction.ml#L367 *) Opaque reduce_stack. @@ -3292,7 +3292,7 @@ Qed. isconv_red leq t1 (Lambda_bd na A1 :: π1) t2 (Lambda_bd na' A2 :: π2) aux ; - | exist false e := + | exist false e := no ( LambdaNotConvertibleAnn (Γ ,,, stack_context π1) na A1 t1 @@ -3313,7 +3313,7 @@ Qed. isconv_red leq B1 (Prod_r na A1 :: π1) B2 (Prod_r na' A2 :: π2) aux ; - | exist false e := + | exist false e := no ( ProdNotConvertibleAnn (Γ ,,, stack_context π1) na A1 B1 @@ -3334,7 +3334,7 @@ Qed. | @exist cred' eq3 with inspect (eqb_term cred' c') := { | @exist true eq4 with inspect (eqb ci ci') := { | @exist true eq5 - with isconv_predicate Γ ci p c brs π1 _ ci' p' c' brs' π2 _ _ _ aux := { + with isconv_predicate Γ ci p c brs π1 _ ci' p' c' brs' π2 _ _ _ aux := { | Success convp with isconv_red_raw Conv c (Case_discr ci p brs :: π1) c' (Case_discr ci' p' brs' :: π2) aux := { @@ -3469,11 +3469,11 @@ Qed. simpl. constructor. Qed. Next Obligation. - rename H into wfΣ; destruct (hΣ _ wfΣ). clear aux. + rename H into wfΣ; destruct (hΣ _ wfΣ). clear aux. specialize_Σ wfΣ. apply conv_cum_zipp; auto. constructor. eapply ws_cumul_pb_eq_le_gen. - constructor. all:fvs. + constructor. all:fvs. - destruct h. eapply welltyped_zipc_zipp in h1; auto. fvs. - constructor. eapply eqb_universe_instance_spec; eauto. + eapply welltyped_zipc_tConst_inv in h1 as (?&?&?); eauto; @@ -3521,13 +3521,13 @@ Qed. * eapply welltyped_zipc_zipp in h1; fvs. } clear aux. eapply welltyped_zipc_zipp in h2; eauto. destruct hx as [hx]. rewrite (All2_fold_length hx); fvs. - Unshelve. all:eauto. + Unshelve. all:eauto. Qed. Next Obligation. apply h; cbn; clear h. intros Σ wfΣ. destruct (hΣ _ wfΣ). eapply conv_cum_red_inv. - - eauto. + - eauto. - apply red_zipp. eapply red_const. erewrite abstract_env_lookup_correct; eauto. - apply red_zipp. @@ -3535,34 +3535,34 @@ Qed. - now eapply H. Qed. Next Obligation. - apply h; clear h. intros Σ wfΣ. + apply h; clear h. intros Σ wfΣ. rewrite !zipp_as_mkApps in H. destruct (hΣ _ wfΣ). eapply conv_cum_mkApps_inv in H as [(?&?)]; eauto. - apply whnf_mkApps. - eapply whne_const. + eapply whne_const. + erewrite abstract_env_lookup_correct; eauto. + eauto. - apply whnf_mkApps. eapply whne_const. + erewrite abstract_env_lookup_correct; eauto. - + eauto. + + eauto. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; - eapply welltyped_zipc_tConst_inv in h1 as (?&?&?); eauto. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + eapply welltyped_zipc_tConst_inv in h1 as (?&?&?); eauto. unfold declared_constant in *. erewrite abstract_env_lookup_correct in d; eauto. congruence. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; - eapply welltyped_zipc_tConst_inv in h1 as (?&?&?); eauto. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + eapply welltyped_zipc_tConst_inv in h1 as (?&?&?); eauto. unfold declared_constant in *. erewrite abstract_env_lookup_correct in d; eauto. congruence. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; - right; split; [easy|]. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + right; split; [easy|]. unfold eqb_universe_instance. now rewrite <- uneq_u. Qed. @@ -3614,7 +3614,7 @@ Qed. Qed. Next Obligation. symmetry in e0. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ. destruct hx as [hx]. apply isred_full_nobeta in ir1; [|easy]. @@ -3786,7 +3786,7 @@ Qed. now apply andb_true_iff in h2 as []. Qed. Next Obligation. - apply h; clear h. intros. + apply h; clear h. intros. eapply inv_reduced_discriminees_case in H as [[<-]]; eauto. Qed. Next Obligation. @@ -3803,7 +3803,7 @@ Qed. eapply inv_reduced_discriminees_case in H as [[<-]]; eauto. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ. eapply inv_reduced_discriminees_case in H as [[<-]]; eauto. now destruct (eqb_spec ci ci). @@ -3814,34 +3814,34 @@ Qed. match goal with | |- context [ reduce_term ?f ?Σ ?hΣ ?Γ ?t ?h ] => pose proof (reduce_term_sound f Σ hΣ Γ t h) as [hr] - end; eauto. + end; eauto. eapply red_welltyped ; [auto|..]. - exact h2'. - eapply red_zipc. eapply red_case_c; auto. eapply hr. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ. match goal with | |- context [ reduce_term ?f _ ?X ?Γ c' ?h ] => destruct (reduce_stack_Req f _ X _ wfΣ Γ c' [] h) as [e' | hr] end. 1:{ - exfalso. Transparent reduce_term. + exfalso. Transparent reduce_term. unfold reduce_term in eq4. rewrite e' in eq4. cbn in eq4. epose proof (eqb_term_upto_univ_refl Σ _ _ _ _ 0 c' _ _). rewrite H in eq4. - discriminate. - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct; eauto. - - intros. rewrite wf_universeb_instance_forall in *. + - intros. rewrite wf_universeb_instance_forall in *. apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. + apply wf_universe_instance_iff in H1. eapply abstract_env_compare_global_instance_correct; eauto. - - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. - apply welltyped_zipc_inv in Hc; eauto. - apply welltyped_wf in Hc; eauto. + - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. + apply welltyped_zipc_inv in Hc; eauto. + apply welltyped_wf in Hc; eauto. cbn in Hc. rtoProp; intuition. } dependent destruction hr. @@ -3855,19 +3855,19 @@ Qed. rewrite H1 in eq4. - discriminate. - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct; eauto. - - intros. rewrite wf_universeb_instance_forall in *. + - intros. rewrite wf_universeb_instance_forall in *. apply wf_universe_instance_iff in H3. - apply wf_universe_instance_iff in H4. + apply wf_universe_instance_iff in H4. eapply abstract_env_compare_global_instance_correct; eauto. - - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. - apply welltyped_zipc_inv in Hc; eauto. - apply welltyped_wf in Hc; eauto. + - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. + apply welltyped_zipc_inv in Hc; eauto. + apply welltyped_wf in Hc; eauto. cbn in Hc. rtoProp; intuition. } unshelve eapply R_cored2. all: try reflexivity. simpl. intros. eapply cored_zipc. eapply cored_case. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. Unshelve. all: eauto. all: intros; eapply abstract_env_compare_universe_correct; eauto; reflexivity. Qed. @@ -3890,14 +3890,14 @@ Qed. * fvs. * clear aux eq4 h hr'. clear hr. eapply welltyped_zipc_zipp in h2; fvs. - Unshelve. all:eauto. + Unshelve. all:eauto. Qed. Next Obligation. apply h; clear h. intros Σ wfΣ. pose proof (hΣ _ wfΣ) as []. pose proof hx as hx'. specialize_Σ wfΣ. destruct hx'. - epose proof (reduce_term_sound _ _ _ _ _ _) as [r]; eauto. + epose proof (reduce_term_sound _ _ _ _ _ _) as [r]; eauto. eapply conv_cum_red_conv_inv. all: tea. 1: reflexivity. @@ -3907,12 +3907,12 @@ Qed. Qed. Next Obligation. - pose proof (heΣ _ wfΣ) as []. pose proof h1 as h1'. + pose proof (heΣ _ wfΣ) as []. pose proof h1 as h1'. clear aux eq3. specialize_Σ wfΣ. match goal with | |- context [ reduce_term ?f ?Σ ?hΣ ?Γ ?t ?h ] => pose proof (reduce_term_sound f Σ hΣ Γ t h) as [hr] - end; eauto. + end; eauto. sq. eapply red_welltyped ; [auto|..]. - exact h1'. @@ -3920,7 +3920,7 @@ Qed. apply red_case_c, hr. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. match goal with | |- context [ reduce_term ?f _ ?X ?Γ c ?h ] => destruct (reduce_stack_Req f _ X _ wfΣ Γ c [] h) as [e' | hr] @@ -3933,13 +3933,13 @@ Qed. rewrite H in eq3. - discriminate. - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct; eauto. - - intros. rewrite wf_universeb_instance_forall in *. + - intros. rewrite wf_universeb_instance_forall in *. apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. + apply wf_universe_instance_iff in H1. eapply abstract_env_compare_global_instance_correct; eauto. - - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. - apply welltyped_zipc_inv in Hc; eauto. - apply welltyped_wf in Hc; eauto. + - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. + apply welltyped_zipc_inv in Hc; eauto. + apply welltyped_wf in Hc; eauto. cbn in Hc. rtoProp; intuition. } dependent destruction hr. @@ -3953,19 +3953,19 @@ Qed. rewrite H1 in eq3. - discriminate. - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct; eauto. - - intros. rewrite wf_universeb_instance_forall in *. + - intros. rewrite wf_universeb_instance_forall in *. apply wf_universe_instance_iff in H3. - apply wf_universe_instance_iff in H4. + apply wf_universe_instance_iff in H4. eapply abstract_env_compare_global_instance_correct; eauto. - - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. - apply welltyped_zipc_inv in Hc; eauto. - apply welltyped_wf in Hc; eauto. + - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. + apply welltyped_zipc_inv in Hc; eauto. + apply welltyped_wf in Hc; eauto. cbn in Hc. rtoProp; intuition. } unshelve eapply R_cored. - simpl. intros; eapply cored_zipc. eapply cored_case. + simpl. intros; eapply cored_zipc. eapply cored_case. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. all: intros; eapply abstract_env_compare_universe_correct; eauto; reflexivity. + Unshelve. all: eauto. all: intros; eapply abstract_env_compare_universe_correct; eauto; reflexivity. Qed. Next Obligation. rename H into wfΣ; specialize_Σ wfΣ. @@ -3983,16 +3983,16 @@ Qed. eapply red_case_c, hr'. * fvs. * clear eq3 h hr' hr; eapply welltyped_zipc_zipp in h1; fvs. - - assumption. - Unshelve. all:eauto. + - assumption. + Unshelve. all:eauto. Qed. Next Obligation. - apply h; clear h. intros Σ wfΣ. + apply h; clear h. intros Σ wfΣ. pose proof (hΣ _ wfΣ) as []. destruct (hx _ wfΣ). - epose proof (reduce_term_sound _ _ _ _ _ _) as [r]; eauto. + epose proof (reduce_term_sound _ _ _ _ _ _) as [r]; eauto. eapply conv_cum_red_inv. - 1: eauto. + 1: eauto. 2: reflexivity. - apply red_zipp, red_case_c, r. - destruct (H _ wfΣ) as []. sq; eauto. @@ -4078,13 +4078,13 @@ Qed. rewrite H in eq4. - discriminate. - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct; eauto. - - intros. rewrite wf_universeb_instance_forall in *. + - intros. rewrite wf_universeb_instance_forall in *. apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. + apply wf_universe_instance_iff in H1. eapply abstract_env_compare_global_instance_correct; eauto. - - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. - apply welltyped_zipc_inv in Hc; eauto. - apply welltyped_wf in Hc; eauto. + - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. + apply welltyped_zipc_inv in Hc; eauto. + apply welltyped_wf in Hc; eauto. } dependent destruction hr. 2:{ @@ -4097,19 +4097,19 @@ Qed. rewrite H1 in eq4. - discriminate. - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct; eauto. - - intros. rewrite wf_universeb_instance_forall in *. + - intros. rewrite wf_universeb_instance_forall in *. apply wf_universe_instance_iff in H3. - apply wf_universe_instance_iff in H4. + apply wf_universe_instance_iff in H4. eapply abstract_env_compare_global_instance_correct; eauto. - - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. - apply welltyped_zipc_inv in Hc; eauto. - apply welltyped_wf in Hc; eauto. + - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. + apply welltyped_zipc_inv in Hc; eauto. + apply welltyped_wf in Hc; eauto. } unshelve eapply R_cored2. all: try reflexivity. - simpl. intros; eapply cored_zipc. eapply cored_proj. + simpl. intros; eapply cored_zipc. eapply cored_proj. erewrite (abstract_env_ext_irr _ _ wfΣ); eassumption. - Unshelve. all: eauto. all: intros; eapply abstract_env_compare_universe_correct; eauto; reflexivity. + Unshelve. all: eauto. all: intros; eapply abstract_env_compare_universe_correct; eauto; reflexivity. Qed. Next Obligation. rename H into wfΣ. specialize_Σ wfΣ. @@ -4129,10 +4129,10 @@ Qed. eapply red_proj_c, hr'. * fvs. * clear hr hr' h eq4 aux. eapply welltyped_zipc_zipp in h2; fvs. - Unshelve. all:eauto. + Unshelve. all:eauto. Qed. Next Obligation. - apply h; cbn; clear h. intros Σ wfΣ. + apply h; cbn; clear h. intros Σ wfΣ. pose proof (hΣ _ wfΣ) as w. destruct w. specialize_Σ wfΣ. destruct hx as [hx]. @@ -4149,14 +4149,14 @@ Qed. eapply red_proj_c, hr'. * fvs. * clear eq4 aux hr hr'. eapply welltyped_zipc_zipp in h2; fvs. - Unshelve. all:eauto. + Unshelve. all:eauto. Qed. Next Obligation. pose proof (heΣ _ wfΣ) as []. match goal with | |- context [ reduce_term ?f _ ?X ?Γ ?t ?h ] => pose proof (reduce_term_sound f _ X Γ t h) as [hr] - end; eauto. + end; eauto. sq. eapply red_welltyped ; [auto|..]. - exact (h1 _ wfΣ). @@ -4177,13 +4177,13 @@ Qed. rewrite H in eq3. - discriminate. - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct; eauto. - - intros. rewrite wf_universeb_instance_forall in *. + - intros. rewrite wf_universeb_instance_forall in *. apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. + apply wf_universe_instance_iff in H1. eapply abstract_env_compare_global_instance_correct; eauto. - - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. - apply welltyped_zipc_inv in Hc; eauto. - apply welltyped_wf in Hc; eauto. + - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. + apply welltyped_zipc_inv in Hc; eauto. + apply welltyped_wf in Hc; eauto. } dependent destruction hr. 2:{ @@ -4196,18 +4196,18 @@ Qed. rewrite H1 in eq3. - discriminate. - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct; eauto. - - intros. rewrite wf_universeb_instance_forall in *. + - intros. rewrite wf_universeb_instance_forall in *. apply wf_universe_instance_iff in H3. - apply wf_universe_instance_iff in H4. + apply wf_universe_instance_iff in H4. eapply abstract_env_compare_global_instance_correct; eauto. - - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. - apply welltyped_zipc_inv in Hc; eauto. - apply welltyped_wf in Hc; eauto. + - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. + apply welltyped_zipc_inv in Hc; eauto. + apply welltyped_wf in Hc; eauto. } unshelve eapply R_cored. - simpl. intros; eapply cored_zipc. eapply cored_proj. + simpl. intros; eapply cored_zipc. eapply cored_proj. erewrite (abstract_env_ext_irr _ _ wfΣ); eassumption. - Unshelve. all: eauto. all: intros; eapply abstract_env_compare_universe_correct; eauto; reflexivity. + Unshelve. all: eauto. all: intros; eapply abstract_env_compare_universe_correct; eauto; reflexivity. Qed. Next Obligation. rename H into wfΣ. specialize_Σ wfΣ. @@ -4226,7 +4226,7 @@ Qed. * fvs. * clear eq3 aux hr hr' h. eapply welltyped_zipc_zipp in h1; fvs. - assumption. - Unshelve. all:eauto. + Unshelve. all:eauto. Qed. Next Obligation. apply h; cbn; clear h. intros Σ wfΣ. @@ -4245,14 +4245,14 @@ Qed. * fvs. * clear hr hr' H eq3. eapply welltyped_zipc_zipp in h1; fvs. - assumption. - Unshelve. all:eauto. + Unshelve. all:eauto. Qed. - + (* tFix *) Next Obligation. pose proof (hΣ _ wfΣ) as hΣ. cbn. rewrite zipc_appstack. cbn. - eapply unfold_one_fix_red_zipp in eq1 as r; eauto. + eapply unfold_one_fix_red_zipp in eq1 as r; eauto. sq. apply unfold_one_fix_decompose in eq1 as d. rewrite <- eq2 in d. simpl in d. @@ -4270,7 +4270,7 @@ Qed. Qed. Next Obligation. pose proof (heΣ _ wfΣ). - eapply unfold_one_fix_red in eq1 as r1; eauto. + eapply unfold_one_fix_red in eq1 as r1; eauto. eapply unfold_one_fix_decompose in eq1 as d1. reduce_stack_facts Σ wfΣ. simpl_stacks. @@ -4286,10 +4286,10 @@ Qed. eassumption. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (heΣ _ wfΣ) as heΣ. specialize_Σ wf. - eapply unfold_one_fix_cored in eq1 as r1; eauto. + eapply unfold_one_fix_cored in eq1 as r1; eauto. eapply unfold_one_fix_decompose in eq1 as d1. match type of eq3 with | _ = reduce_stack ?f _ ?X ?Γ ?t ?π ?h => @@ -4306,7 +4306,7 @@ Qed. rewrite zipc_appstack in r2. cbn in r2. rewrite zipc_appstack. assumption. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. apply unfold_one_fix_decompose in eq1 as d1. @@ -4317,10 +4317,10 @@ Qed. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. simpl_reduce_stack Σ wfΣ. specialize (isr eq_refl) as (?&_). - split; [easy|]. intros. - cbn in *. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + split; [easy|]. intros. + cbn in *. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. now simpl_stacks. - Unshelve. all:eauto. + Unshelve. all:eauto. Qed. Lemma wt_zip_mkapps Σ (wfΣ:abstract_env_ext_rel X Σ) Γ f π : welltyped Σ Γ (zipc f π) -> is_open_term (Γ ,,, stack_context π) (mkApps f (decompose_stack π).1). @@ -4344,11 +4344,11 @@ Qed. eapply (f_equal stack_context) in d1. rewrite !stack_context_decompose in d1. rewrite <- d1. now eapply wt_zip_mkapps. - Unshelve. all:eauto. + Unshelve. all:eauto. Qed. Next Obligation. apply h; clear h. intros Σ wfΣ. - eapply unfold_one_fix_red_zipp in eq1 as r1; eauto. + eapply unfold_one_fix_red_zipp in eq1 as r1; eauto. apply unfold_one_fix_decompose in eq1 as d1. reduce_stack_facts Σ wfΣ. simpl_reduce_stack Σ wfΣ. @@ -4369,7 +4369,7 @@ Qed. Qed. Next Obligation. pose proof (heΣ _ wfΣ). - eapply unfold_one_fix_red_zipp in eq1 as r; eauto. + eapply unfold_one_fix_red_zipp in eq1 as r; eauto. sq. apply unfold_one_fix_decompose in eq1 as d. clear aux eq1. @@ -4404,9 +4404,9 @@ Qed. rewrite zipc_stack_cat. assumption. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; pose proof (heΣ _ wfΣ) as heΣ. - eapply unfold_one_fix_cored in eq1 as r1; eauto. + eapply unfold_one_fix_cored in eq1 as r1; eauto. apply unfold_one_fix_decompose in eq1 as d1. match type of eq3 with | _ = reduce_stack ?f _ ?X ?Γ ?t ?π ?h => @@ -4414,7 +4414,7 @@ Qed. end. rewrite <- eq3 in r2. eapply R_cored2. all: try reflexivity. simpl. intros. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. eapply red_cored_cored ; try eassumption. cbn in r2. rewrite zipc_stack_cat. @@ -4422,7 +4422,7 @@ Qed. rewrite zipc_appstack in r2. cbn in r2. rewrite zipc_appstack. do 2 zip fold. eapply red_context_zip, r2. - Unshelve. eauto. + Unshelve. eauto. Qed. Next Obligation. apply unfold_one_fix_decompose in eq1 as d1. @@ -4444,19 +4444,19 @@ Qed. apply decompose_stack_eq in e2 as ?. subst. clear eq3. rewrite stack_context_appstack in hx. - eauto. + eauto. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. simpl_reduce_stack Σ wfΣ. specialize (isr eq_refl) as (?&_). - split; [easy|]. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + split; [easy|]. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. simpl_stacks. eauto. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. - eapply unfold_one_fix_red_zipp in eq1 as r1; eauto. + eapply unfold_one_fix_red_zipp in eq1 as r1; eauto. apply unfold_one_fix_decompose in eq1 as d1. reduce_stack_facts Σ H. simpl_reduce_stack Σ H. @@ -4466,7 +4466,7 @@ Qed. 1,4: eauto. * eapply closed_red_refl; [fvs|]. now eapply wt_zip_mkapps. - * etransitivity; eauto. + * etransitivity; eauto. eapply into_closed_red. + eapply r1. + fvs. @@ -4476,18 +4476,18 @@ Qed. Qed. Next Obligation. apply h; clear h. intros Σ wfΣ. - eapply unfold_one_fix_red_zipp in eq1 as r1; eauto. + eapply unfold_one_fix_red_zipp in eq1 as r1; eauto. apply unfold_one_fix_decompose in eq1 as d1. - reduce_stack_facts Σ wfΣ. + reduce_stack_facts Σ wfΣ. simpl_reduce_stack Σ wfΣ. destruct r1 as [r1]. destruct (hΣ Σ wfΣ), (hx Σ wfΣ). - specialize (H Σ wfΣ). - eapply conv_cum_red_conv_inv. - 1,2,5: eauto. + specialize (H Σ wfΣ). + eapply conv_cum_red_conv_inv. + 1,2,5: eauto. * eapply closed_red_refl. 1:fvs. now eapply wt_zip_mkapps. - * etransitivity; eauto. sq. + * etransitivity; eauto. sq. eapply r. Qed. Next Obligation. @@ -4511,12 +4511,12 @@ Qed. subst. eapply ws_cumul_pb_Fix; eauto. - clear aux eee. eapply welltyped_zipc_zipp in h1; fvs. - - eapply All2_impl; eauto. intros. + - eapply All2_impl; eauto. intros. split; try eapply X0; eauto. split; try eapply X0; eauto. Qed. Next Obligation. - apply h; clear h. intros. + apply h; clear h. intros. eapply inv_stuck_fixes in H as [[<-]]; eauto. Qed. Next Obligation. @@ -4524,12 +4524,12 @@ Qed. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. eapply inv_stuck_fixes in H as [[<-]]; eauto. constructor; auto. - eapply All2_impl; eauto. cbn; intros. + eapply All2_impl; eauto. cbn; intros. destruct X0 as [Xr [Xe [Xd Xb]]]. cbn; intros. repeat split; intros; eauto. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. @@ -4559,23 +4559,23 @@ Qed. subst. eapply ws_cumul_pb_CoFix; eauto. - clear aux h1'. eapply welltyped_zipc_zipp in h1; fvs. - - eapply All2_impl; eauto. now cbn; intros. + - eapply All2_impl; eauto. now cbn; intros. Qed. Next Obligation. - apply h; clear h. intros. + apply h; clear h. intros. eapply inv_stuck_cofixes in H as [(<-&?&?)]; eauto. Qed. Next Obligation. - apply h; clear h. + apply h; clear h. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. eapply inv_stuck_cofixes in H as [(<-&?&?)]; eauto. constructor; auto. eapply All2_impl; eauto; cbn; intros. - destruct X0 as [Xr [Xe [Xd Xb]]]. + destruct X0 as [Xr [Xe [Xd Xb]]]. repeat split; intros; eauto. - - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. @@ -4701,7 +4701,7 @@ Qed. constructor; auto. Qed. Next Obligation. - apply herr; cbn; clear herr. intros Σ wfΣ. specialize_Σ wfΣ. + apply herr; cbn; clear herr. intros Σ wfΣ. specialize_Σ wfΣ. destruct H as [H]; depelim H. rewrite stack_context_appstack. constructor; auto. @@ -4767,7 +4767,7 @@ Qed. Qed. Obligation Tactic := Tactics.program_simplify; CoreTactics.equations_simpl; try Tactics.program_solve_wf. - + Equations unfold_one_case (Γ : context) (ci : case_info) (p : predicate term) (c : term) (brs : list (branch term)) (h : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ (tCase ci p c brs)) : option term := @@ -4807,7 +4807,7 @@ Qed. apply PCUICInductiveInversion.invert_Case_Construct in X0 as (?&?&?&?); auto. congruence. Qed. - + Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. simpl_reduce_stack Σ wfΣ. @@ -4845,7 +4845,7 @@ Qed. destruct (h _ wfΣ) as (?&typ). eapply PCUICSR.subject_reduction in typ; eauto. apply PCUICInductiveInversion.invert_Case_Construct in typ as (?&?&?&?); auto. - rewrite H0 in eqbr; noconf eqbr. eauto. + rewrite H0 in eqbr; noconf eqbr. eauto. + eapply red_case_c, r. - clear H H0 H1. simpl_reduce_stack Σ wfΣ. @@ -4858,7 +4858,7 @@ Qed. + constructor. eapply red_cofix_case. eauto. + eapply red_case_c, r. Qed. - + Lemma unfold_one_case_None Σ (wfΣ : abstract_env_ext_rel X Σ) Γ ci p c brs h : None = unfold_one_case Γ ci p c brs h -> ∥∑ c', red Σ Γ c c' × whne RedFlags.default Σ Γ c'∥. @@ -5050,7 +5050,7 @@ Qed. funelim (reducible_head Γ t π h). all: intro ee ; noconf ee. - eapply unfold_one_fix_red_zipp; eauto. - - constructor. simpl_stacks. + - constructor. simpl_stacks. eapply red_mkApps_f. eapply trans_red. + reflexivity. @@ -5119,13 +5119,13 @@ Qed. - eapply unfold_one_fix_cored; eauto. - repeat zip fold. eapply cored_context. constructor. eapply red_delta. - + unfold declared_constant. + + unfold declared_constant. erewrite abstract_env_lookup_correct; eauto. + reflexivity. - repeat zip fold. eapply cored_context. eapply unfold_one_case_cored; eauto. - repeat zip fold. eapply cored_context. - eapply unfold_one_proj_cored; eauto. + eapply unfold_one_proj_cored; eauto. Qed. Lemma reducible_head_decompose : @@ -5144,7 +5144,7 @@ Qed. Qed. (* TODO move to PCUICNormal *) - Lemma whnf_mkApps_tPrim_inv : + Lemma whnf_mkApps_tPrim_inv : forall (f : RedFlags.t) (Σ : global_env) (Γ : context) p (args : list term), whnf f Σ Γ (mkApps (tPrim p) args) -> args = []. Proof. @@ -5212,7 +5212,7 @@ Qed. - discriminate. - constructor; eexists _, (decompose_stack π).1; eauto using whnf_red with pcuic. - constructor; eexists _, (decompose_stack π).1; eauto using whnf_red with pcuic. - - eapply unfold_one_fix_None in H0 as [(?&?&?)]; eauto. + - eapply unfold_one_fix_None in H0 as [(?&?&?)]; eauto. constructor; eexists _, x. split; [constructor; eauto with pcuic|]. eauto with pcuic. @@ -5223,7 +5223,7 @@ Qed. constructor; eexists _, []. eauto using whnf_red with pcuic. - constructor; eexists _, (decompose_stack π).1. - clear H. erewrite <- abstract_env_lookup_correct in e; eauto. + clear H. erewrite <- abstract_env_lookup_correct in e; eauto. split; [econstructor|]; eauto. split; [eauto with pcuic|]. apply whnf_mkApps. @@ -5233,8 +5233,8 @@ Qed. eapply welltyped_context in h; eauto. destruct h as (?&typ); auto. apply inversion_Const in typ as (?&?&?&?); auto. - unfold declared_constant in d. - clear H. erewrite <- abstract_env_lookup_correct in e; eauto. + unfold declared_constant in d. + clear H. erewrite <- abstract_env_lookup_correct in e; eauto. congruence. - zip fold in h. destruct (hΣ _ wfΣ). @@ -5242,10 +5242,10 @@ Qed. destruct h as (?&typ); auto. apply inversion_Const in typ as (?&?&?&?); auto. unfold declared_constant in d. - clear H. erewrite <- abstract_env_lookup_correct in e; eauto. + clear H. erewrite <- abstract_env_lookup_correct in e; eauto. congruence. - clear H. - eapply unfold_one_case_None in e as [(c'&r&whcase)]; eauto. + eapply unfold_one_case_None in e as [(c'&r&whcase)]; eauto. constructor; exists (tCase ci p c' brs), (decompose_stack π).1. split. + destruct p. constructor; eauto with pcuic. @@ -5253,7 +5253,7 @@ Qed. apply whnf_mkApps. auto. - clear H. - eapply unfold_one_proj_None in e as [(c'&r&whproj)]; eauto. + eapply unfold_one_proj_None in e as [(c'&r&whproj)]; eauto. constructor; exists (tProj p c'), (decompose_stack π).1. split. + constructor; eauto with pcuic. @@ -5261,7 +5261,7 @@ Qed. apply whnf_mkApps. auto. Qed. - + (* TODO Factorise *) Equations(noeqns) _isconv_fallback (Γ : context) (leq : conv_pb) (t1 : term) (π1 : stack) (h1 : wtp Γ t1 π1) @@ -5323,10 +5323,10 @@ Qed. simpl_stacks. eapply red_welltyped. 1:auto. 2: exact r1. - eauto. + eauto. Qed. Next Obligation. - eapply R_cored. simpl. intros. + eapply R_cored. simpl. intros. eapply reducible_head_cored in eq1 as r1; eauto. apply reducible_head_decompose in eq1 as d1. rewrite <- eq2 in d1. cbn in d1. @@ -5363,12 +5363,12 @@ Qed. simpl_reduce_stack Σ wfΣ. specialize (isr eq_refl) as (?&_). split; auto. intros. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. now simpl_stacks. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. - eapply reducible_head_red_zipp in eq1 as r1; eauto. + eapply reducible_head_red_zipp in eq1 as r1; eauto. destruct r1 as [r1]. apply reducible_head_decompose in eq1 as d1. simpl_reduce_stack Σ H. @@ -5384,8 +5384,8 @@ Qed. Unshelve. all:eauto. Qed. Next Obligation. - apply h; clear h. intros Σ wfΣ. - eapply reducible_head_red_zipp in eq1 as r1; eauto. + apply h; clear h. intros Σ wfΣ. + eapply reducible_head_red_zipp in eq1 as r1; eauto. destruct r1 as [r1]. apply reducible_head_decompose in eq1 as d1. simpl_reduce_stack Σ wfΣ. @@ -5400,7 +5400,7 @@ Qed. Unshelve. all:eauto. Qed. Next Obligation. - eapply reducible_head_red_zipp in eq1 as r; eauto. + eapply reducible_head_red_zipp in eq1 as r; eauto. pose proof (hΣ := hΣ _ wfΣ). sq. apply reducible_head_decompose in eq1 as d. @@ -5411,7 +5411,7 @@ Qed. assumption. Qed. Next Obligation. - eapply reducible_head_cored in eq1 as r1; eauto. + eapply reducible_head_cored in eq1 as r1; eauto. apply cored_red in r1. pose proof (hΣ := hΣ _ wfΣ). sq. @@ -5472,17 +5472,17 @@ Qed. now simpl_reduce_stack Σ H. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; simpl_reduce_stack Σ wfΣ. specialize (isr eq_refl) as (?&_). - split; auto. intros. + split; auto. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. now simpl_stacks. - Unshelve. all: eauto. + Unshelve. all: eauto. Qed. Next Obligation. destruct (hΣ _ H) as [wΣ]. - eapply reducible_head_red_zipp in eq1 as r1; eauto. + eapply reducible_head_red_zipp in eq1 as r1; eauto. destruct r1 as [r1]. apply reducible_head_decompose in eq1 as d1. simpl_reduce_stack Σ H. @@ -5503,7 +5503,7 @@ Qed. apply h; clear h. intros Σ wfΣ. (* Contrapositive of previous case *) destruct (hΣ _ wfΣ) as [wΣ]. - eapply reducible_head_red_zipp in eq1 as r1; eauto. + eapply reducible_head_red_zipp in eq1 as r1; eauto. destruct r1 as [r1]. apply reducible_head_decompose in eq1 as d1. simpl_reduce_stack Σ wfΣ. @@ -5517,7 +5517,7 @@ Qed. eapply into_closed_red; [exact r1|..]. 1:fvs. rewrite <- d1; now eapply wt_zip_mkapps. - eauto. - Unshelve. all:eauto. + Unshelve. all:eauto. Qed. Next Obligation. eapply R_stateR. all: simpl. all: try reflexivity. @@ -5525,7 +5525,7 @@ Qed. Qed. Next Obligation. - destruct (h _ H), (hΣ _ H). + destruct (h _ H), (hΣ _ H). eapply ws_cumul_pb_terms_alt in X0 as (argsr&argsr'&[]). rewrite !zipp_as_mkApps. apply conv_cum_alt; auto. @@ -5539,7 +5539,7 @@ Qed. * clear aux nored1. eapply welltyped_zipc_zipp in h1; fvs. * clear aux nored1 nored2. eapply wt_zip_mkapps in h1; eauto. eapply wt_zip_mkapps in h2; eauto. destruct (hx _ H). - rewrite (All2_fold_length X0). + rewrite (All2_fold_length X0). rewrite on_free_vars_mkApps in h2. now apply andb_true_iff in h2. - apply eq_term_upto_univ_napp_mkApps; auto. rewrite Nat.add_0_r. @@ -5548,24 +5548,24 @@ Qed. eapply eqb_term_upto_univ_impl with (q := closedu); eauto. + intros. eapply iff_reflect. eapply (abstract_env_compare_universe_correct _ H Conv) ; now eapply wf_universe_iff. - + intros. eapply iff_reflect. destruct leq. + + intros. eapply iff_reflect. destruct leq. * eapply (abstract_env_compare_universe_correct _ H Conv) ; now eapply wf_universe_iff. * eapply (abstract_env_compare_universe_correct _ H Cumul) ; now eapply wf_universe_iff. - + intros. rewrite wf_universeb_instance_forall in *. + + intros. rewrite wf_universeb_instance_forall in *. apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. + apply wf_universe_instance_iff in H1. eapply (abstract_env_compare_global_instance_correct _ H); eauto. intros. apply X0; now eapply wf_universe_iff. - + pose proof h1 as Hc. specialize_Σ H. pose proof (hΣ _ H); sq. - apply welltyped_zipc_inv in Hc; eauto. - apply welltyped_wf in Hc; eauto. - + pose proof h2 as Hc. specialize_Σ H. pose proof (hΣ _ H); sq. - apply welltyped_zipc_inv in Hc; eauto. - apply welltyped_wf in Hc; eauto. + + pose proof h1 as Hc. specialize_Σ H. pose proof (hΣ _ H); sq. + apply welltyped_zipc_inv in Hc; eauto. + apply welltyped_wf in Hc; eauto. + + pose proof h2 as Hc. specialize_Σ H. pose proof (hΣ _ H); sq. + apply welltyped_zipc_inv in Hc; eauto. + apply welltyped_wf in Hc; eauto. Qed. Next Obligation. apply h; clear h. intros Σ wfΣ. - destruct ir1 as (notapp1&[whδ1]), ir2 as (notapp2&[whδ2]); eauto. + destruct ir1 as (notapp1&[whδ1]), ir2 as (notapp2&[whδ2]); eauto. erewrite !zipp_as_mkApps in *. eapply reducible_head_None in nored1 as [(?&?&s1&r1&wh1)]; eauto. eapply reducible_head_None in nored2 as [(?&?&s2&r2&wh2)]; eauto. @@ -5577,7 +5577,7 @@ Qed. 2: eassumption. 2: eapply red_mkApps; eauto. 2: apply red_mkApps; eauto. - 2: eauto. + 2: eauto. eapply conv_cum_mkApps_inv in H as [(?&?)]; eauto. 2: now depelim s1. 2: now depelim s2. @@ -5587,17 +5587,17 @@ Qed. eapply ws_cumul_pb_terms_red_conv; eauto. all:eapply into_red_terms; tea. 1:fvs. 2:fvs. - all:clear aux. - * eapply wt_zip_mkapps in h1; eauto. + all:clear aux. + * eapply wt_zip_mkapps in h1; eauto. rewrite on_free_vars_mkApps in h1. now apply andb_true_iff in h1 as []. - * eapply wt_zip_mkapps in h2; eauto. + * eapply wt_zip_mkapps in h2; eauto. rewrite on_free_vars_mkApps in h2. now apply andb_true_iff in h2 as []. Qed. Next Obligation. unfold eqb_termp_napp in noteq. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - destruct ir1 as (notapp1&[whδ1]), ir2 as (notapp2&[whδ2]); eauto. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. + destruct ir1 as (notapp1&[whδ1]), ir2 as (notapp2&[whδ2]); eauto. erewrite !zipp_as_mkApps in *. eapply reducible_head_None in nored1 as [(?&?&s1&rargs1&wh1)]; eauto. eapply reducible_head_None in nored2 as [(?&?&s2&rargs2&wh2)]; eauto. @@ -5632,16 +5632,16 @@ Qed. apply inversion_Ind in typ2 as (?&?&?&?&?&?); auto. apply consistent_instance_ext_wf in c0. apply consistent_instance_ext_wf in c. - epose abstract_env_compare_global_instance_correct as Hcompare. - eapply Hcompare in H3; eauto. - 2: { intros; apply iff_reflect. eapply (abstract_env_compare_universe_correct _ _ leq); apply wf_universe_iff; eauto. - all: apply wf_universe_iff; eauto. + epose abstract_env_compare_global_instance_correct as Hcompare. + eapply Hcompare in H3; eauto. + 2: { intros; apply iff_reflect. eapply (abstract_env_compare_universe_correct _ _ leq); apply wf_universe_iff; eauto. + all: apply wf_universe_iff; eauto. } rewrite eqb_refl in noteq. apply All2_length in rargs1. - rewrite <- rargs1 in H3. + rewrite <- rargs1 in H3. apply ssrbool.not_false_is_true. rewrite noteq. - destruct leq; eauto. + destruct leq; eauto. } 9: { destruct conv_hds as [H]. inversion H; subst; clear H. @@ -5660,10 +5660,10 @@ Qed. rewrite !eqb_refl in noteq. apply All2_length in rargs1. rewrite <- rargs1 in H4. - apply ssrbool.not_false_is_true. rewrite noteq. cbn. + apply ssrbool.not_false_is_true. rewrite noteq. cbn. eapply abstract_env_compare_global_instance_correct; eauto. - intros; apply iff_reflect. - destruct leq; eapply abstract_env_compare_universe_correct; eauto. + intros; apply iff_reflect. + destruct leq; eapply abstract_env_compare_universe_correct; eauto. } all: apply conv_cum_alt in conv_hds as [(?&?&[r1 r2 ?])]; auto. all: eapply whnf_red_inv in r1; auto. @@ -5689,10 +5689,10 @@ Qed. apply inversion_Sort in h2 as (_&h2&_); auto. apply inversion_Sort in h1 as (_&h1&_); auto. eapply compare_universeb_complete in H0; eauto. - destruct leq; cbn in *; easy. - Unshelve. all:eauto. + destruct leq; cbn in *; easy. + Unshelve. all:eauto. Qed. - + Equations _isconv (s : state) (Γ : context) (t1 : term) (π1 : stack) (h1 : wtp Γ t1 π1) (t2 : term) (π2 : stack) (h2 : wtp Γ t2 π2) @@ -5709,16 +5709,16 @@ Qed. _isconv Fallback Γ t1 π1 h1 t2 π2 h2 aux := λ { | leq | hx | r1 | r2 | hd := _isconv_fallback Γ leq t1 π1 h1 t2 π2 h2 r1 r2 hd hx aux }. - + Derive Signature for dlexmod. - + Lemma welltyped_R_zipc Σ (wfΣ : abstract_env_ext_rel X Σ) Γ : forall x y : pack Γ, welltyped Σ Γ (zipc (tm1 x) (stk1 x)) -> R Γ y x -> welltyped Σ Γ (zipc (tm1 y) (stk1 y)). Proof using Type. intros x y H HR. pose proof (heΣ := heΣ _ wfΣ). pose proof (hΣ := hΣ _ wfΣ). cbn. - sq. + sq. destruct x, y; cbn in *. depind HR. - cbn in *. specialize_Σ wfΣ. @@ -5753,7 +5753,7 @@ Qed. Defined. Next Obligation. match goal with | |- Acc _ ?X => set (u := X) end. - revert h1. + revert h1. change ((forall Σ, abstract_env_ext_rel X Σ -> welltyped Σ Γ (zipc (tm1 u) (stk1 u))) -> Acc (R Γ) u). generalize u. refine (Acc_intro_generator @@ -5764,7 +5764,7 @@ Qed. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. destruct (hΣ _ wfΣ) as [hΣ]. eapply R_Acc; eassumption. Defined. - + Inductive ConversionResultSummary := | ConvSuccess : ConversionResultSummary | ConvError : ConversionError -> ConversionResultSummary. @@ -5774,7 +5774,7 @@ Qed. | Success _ => ConvSuccess | Error e _ => ConvError e end. - + Theorem isconv_sound : forall Σ (wfΣ : abstract_env_ext_rel X Σ) Γ leq t1 π1 h1 t2 π2 h2 hx, isconv Γ leq t1 π1 h1 t2 π2 h2 hx = ConvSuccess -> @@ -5786,7 +5786,7 @@ Qed. - auto. - discriminate. Qed. - + Theorem isconv_complete : forall Σ (wfΣ : abstract_env_ext_rel X Σ) Γ leq t1 π1 h1 t2 π2 h2 hx e, isconv Γ leq t1 π1 h1 t2 π2 h2 hx = ConvError e -> @@ -5798,18 +5798,18 @@ Qed. - intros ? [=]. - intros. intro not; eapply h. intros. erewrite (abstract_env_ext_irr _ _ wfΣ) ; eauto. - Unshelve. eauto. + Unshelve. eauto. Qed. Program Definition isconv_term Γ leq t1 (h1 : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ t1) t2 (h2 : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ t2) := isconv Γ leq t1 [] h1 t2 [] h2 _. - + Next Obligation. destruct (h1 _ H), (hΣ _ H) as [wΣ]. - sq. eapply ws_cumul_ctx_pb_refl. + sq. eapply ws_cumul_ctx_pb_refl. fvs. Qed. - + Theorem isconv_term_sound : forall Σ (wfΣ : abstract_env_ext_rel X Σ) Γ leq t1 h1 t2 h2, isconv_term Γ leq t1 h1 t2 h2 = ConvSuccess -> @@ -5827,10 +5827,10 @@ Qed. Proof using Type. intros Σ wfΣ Γ leq t1 h1 t2 h2 e. unfold isconv_term. intro h. - eapply isconv_complete in h; eauto. + eapply isconv_complete in h; eauto. Qed. Transparent reduce_stack. - + End Conversion. (* @@ -5841,7 +5841,7 @@ Defined. Lemma test_conv : match - isconv_term (cf := default_checker_flags) + isconv_term (cf := default_checker_flags) (nor := default_normal) canonical_abstract_env_ext_impl {| diff --git a/safechecker/theories/PCUICSafeReduce.v b/safechecker/theories/PCUICSafeReduce.v index 88703ed65..b0ad5b449 100644 --- a/safechecker/theories/PCUICSafeReduce.v +++ b/safechecker/theories/PCUICSafeReduce.v @@ -1085,11 +1085,11 @@ Corollary R_Acc_aux : Section reducewf. Context (Γ : context). - + Notation sigmaarg := (sigma (fun t => sigma (fun π => forall Σ, abstract_env_ext_rel X Σ -> welltyped Σ Γ (zipc t π)))). - Local Instance wf_proof : WellFounded (fun x y : sigmaarg => + Local Instance wf_proof : WellFounded (fun x y : sigmaarg => forall Σ, abstract_env_ext_rel X Σ -> R Σ Γ (pr1 x, pr1 (pr2 x)) (pr1 y, pr1 (pr2 y))). Proof. intros [t [π wt]]. @@ -1104,7 +1104,7 @@ Corollary R_Acc_aux : destruct (hΣ _ wfΣ) as [hΣ]. pose proof (R_Acc Γ (t0.(pr1), t0.(pr2).(pr1)) H). clear -H0. destruct t0 as [t [π wt]]. cbn in *. revert wt. - depind H0. intros wt. constructor. intros. eapply H0. + depind H0. intros wt. constructor. intros. eapply H0. * cbn in H1. exact H1. * reflexivity. Defined. @@ -1235,7 +1235,7 @@ Corollary R_Acc_aux : induction hx using Acc_ind'. cbn. eapply h. assumption. Qed. - + Lemma reduce_stack_prop : forall Γ t π h (P : term × stack -> term × stack -> Prop), (forall t π h aux, @@ -1393,7 +1393,7 @@ Corollary R_Acc_aux : end -> whnf flags Σ Γ (mkApps hd args) -> Σ;;; Γ |- tCase ci p (mkApps hd args) brs : T -> - whne flags Σ Γ (mkApps hd args). + whne flags Σ Γ (mkApps hd args). Proof using Type. intros wf shape wh typ. apply inversion_Case in typ as (?&?&isdecl&?&[]&?); auto. @@ -1454,7 +1454,7 @@ Corollary R_Acc_aux : apply_funelim (_reduce_stack Γ t π h aux); clear -wfΣ. all: simpl. all: intros *. - all: repeat match goal with + all: repeat match goal with [ |- (forall (t' : term) (π' : stack) (hR : forall Σ, abstract_env_ext_rel X Σ -> R Σ _ _ _), { _ : _ | _ }) -> _ ] => intros reduce @@ -1880,7 +1880,7 @@ Section ReduceFns. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. pose proof (hΣ := hΣ _ X _ wfΣ). sq. eapply into_closed_red in r ; fvs. - Unshelve. eauto. + Unshelve. eauto. Qed. Equations? reduce_to_prod (Γ : context) (t : term) @@ -2009,7 +2009,7 @@ Section ReduceFns. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. pose proof (hΣ := hΣ _ _ _ wfΣ). sq. eapply into_closed_red ; fvs. - Unshelve. eauto. + Unshelve. eauto. Qed. (* Definition of assumption-only arities (without lets) *) diff --git a/safechecker/theories/PCUICSafeRetyping.v b/safechecker/theories/PCUICSafeRetyping.v index 6242bfe9c..12fb4296f 100644 --- a/safechecker/theories/PCUICSafeRetyping.v +++ b/safechecker/theories/PCUICSafeRetyping.v @@ -7,9 +7,9 @@ From Coq Require Import Bool String List Program. From MetaCoq.Template Require Import config monad_utils utils uGraph. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics PCUICArities PCUICInduction PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICGlobalEnv - PCUICWeakeningEnv PCUICWeakeningEnvTyp + PCUICWeakeningEnv PCUICWeakeningEnvTyp PCUICReduction - PCUICWeakeningConv PCUICWeakeningTyp + PCUICWeakeningConv PCUICWeakeningTyp PCUICClosed PCUICClosedTyp PCUICSafeLemmata PCUICSubstitution PCUICValidity PCUICGeneration PCUICInversion PCUICValidity PCUICInductives PCUICInductiveInversion PCUICReduction @@ -41,7 +41,7 @@ Add Search Blacklist "obligation". Require Import ssreflect. -Lemma into_ws_cumul_pb_terms_Algo {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ l l'} : +Lemma into_ws_cumul_pb_terms_Algo {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ l l'} : All2 (convAlgo Σ Γ) l l' -> is_closed_context Γ -> forallb (is_open_term Γ) l -> @@ -53,8 +53,8 @@ Proof. Qed. Lemma on_free_vars_ind_predicate_context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind mdecl idecl} : - declared_inductive Σ ind mdecl idecl → - on_free_vars_ctx (closedP (context_assumptions (ind_params mdecl)) xpredT) + declared_inductive Σ ind mdecl idecl → + on_free_vars_ctx (closedP (context_assumptions (ind_params mdecl)) xpredT) (ind_predicate_context ind mdecl idecl). Proof. intros decli. @@ -66,7 +66,7 @@ Qed. Inductive wellinferred {cf: checker_flags} Σ Γ t : Prop := | iswellinferred T : Σ ;;; Γ |- t ▹ T -> wellinferred Σ Γ t. -Definition well_sorted {cf:checker_flags} Σ Γ T := +Definition well_sorted {cf:checker_flags} Σ Γ T := ∥ ∑ u, Σ ;;; Γ |- T ▹□ u ∥. Lemma well_sorted_wellinferred {cf:checker_flags} {Σ Γ T} : @@ -78,7 +78,7 @@ Qed. Coercion well_sorted_wellinferred : well_sorted >-> wellinferred. -Lemma spine_subst_smash_inv {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} +Lemma spine_subst_smash_inv {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ inst Δ s} : wf_local Σ (Γ ,,, Δ) -> spine_subst Σ Γ inst s (smash_context [] Δ) -> @@ -101,7 +101,7 @@ Lemma inductive_cumulative_indices_smash {cf : checker_flags} {Σ : global_env_e PCUICEquality.R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) napp u u' -> forall Γ pars pars', spine_subst Σ Γ pars (List.rev pars) (smash_context [] (subst_instance u (ind_params mdecl))) -> - spine_subst Σ Γ pars' (List.rev pars') (smash_context [] (subst_instance u' (ind_params mdecl))) -> + spine_subst Σ Γ pars' (List.rev pars') (smash_context [] (subst_instance u' (ind_params mdecl))) -> ws_cumul_pb_terms Σ Γ pars pars' -> let indctx := idecl.(ind_indices)@[u] in let indctx' := idecl.(ind_indices)@[u'] in @@ -142,19 +142,19 @@ Context {cf : checker_flags} {nor : normalizing_flags}. Context (X : X_type.π2.π1). - Local Definition heΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : + Local Definition heΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : ∥ wf_ext Σ ∥ := abstract_env_ext_wf _ wfΣ. Local Definition hΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : - ∥ wf Σ ∥ := abstract_env_ext_sq_wf _ _ _ wfΣ. + ∥ wf Σ ∥ := abstract_env_ext_sq_wf _ _ _ wfΣ. Ltac specialize_Σ wfΣ := - repeat match goal with | h : _ |- _ => specialize (h _ wfΣ) end. + repeat match goal with | h : _ |- _ => specialize (h _ wfΣ) end. - Definition on_subterm P Pty Γ t : Type := + Definition on_subterm P Pty Γ t : Type := match t with | tProd na t b => Pty Γ t * Pty (Γ ,, vass na t) b - | tLetIn na d t t' => + | tLetIn na d t t' => Pty Γ t * P Γ d * P (Γ ,, vdef na d t) t' | tLambda na t b => Pty Γ t * P (Γ ,, vass na t) b | _ => True @@ -172,9 +172,9 @@ Qed. #[local] Notation ret t := (t; _). - #[local] Definition principal_type Γ t := + #[local] Definition principal_type Γ t := ∑ T : term, forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ |- t ▹ T ∥. - #[local] Definition principal_sort Γ T := + #[local] Definition principal_sort Γ T := ∑ u, forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ |- T ▹□ u ∥. #[local] Definition principal_type_type {Γ t} (wt : principal_type Γ t) : term := projT1 wt. @@ -194,7 +194,7 @@ Qed. Next Obligation. destruct tx ; cbn in *. destruct (wf _ wfΣ) as [[]], (hΣ _ wfΣ) as [wΣ]. - specialize_Σ wfΣ. + specialize_Σ wfΣ. sq. eapply infering_typing, validity in s as []; eauto. now eexists. @@ -218,14 +218,14 @@ Qed. destruct wf as [[? i]], (hΣ _ wfΣ) as [wΣ]. eapply infering_sort_infering in i ; eauto. eapply wildcard'. exists x0. intros. - erewrite(abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + erewrite(abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Program Definition infer_as_prod Γ T (wfΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) (wf : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ T) - (isprod : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ ∑ na A B, red Σ Γ T (tProd na A B) ∥) : + (isprod : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ ∑ na A B, red Σ Γ T (tProd na A B) ∥) : ∑ na' A' B', forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ ⊢ T ⇝ tProd na' A' B' ∥ := match @reduce_to_prod cf nor _ X Γ T wf with | Checked_comp p => p @@ -239,15 +239,15 @@ Qed. destruct isprod as (?&?&?&?). apply wildcard'. do 3 eexists. - intros. sq. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + intros. sq. + erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. eapply into_closed_red ; tea. 1: fvs. destruct wf. now eapply subject_is_open_term. - Unshelve. eauto. + Unshelve. eauto. Qed. - + Equations lookup_ind_decl ind : typing_result (∑ decl body, forall Σ (wfΣ : abstract_env_ext_rel X Σ), declared_inductive (fst Σ) ind decl body) := lookup_ind_decl ind with inspect (abstract_env_lookup X ind.(inductive_mind)) := @@ -263,27 +263,27 @@ Qed. - now symmetry. Defined. - Lemma lookup_ind_decl_complete Σ (wfΣ : abstract_env_ext_rel X Σ) ind e : lookup_ind_decl ind = TypeError e -> + Lemma lookup_ind_decl_complete Σ (wfΣ : abstract_env_ext_rel X Σ) ind e : lookup_ind_decl ind = TypeError e -> ((∑ mdecl idecl, declared_inductive Σ ind mdecl idecl) -> False). Proof using Type. - cbn. + cbn. apply_funelim (lookup_ind_decl ind). 1-2: intros * _ her [mdecl [idecl [declm decli]]]; red in declm; erewrite <- abstract_env_lookup_correct, declm in e0; eauto; - congruence. + congruence. 1-2:intros * _ _ => // => _ [mdecl [idecl [declm /= decli]]]. red in declm. erewrite <- abstract_env_lookup_correct, declm in look; eauto. noconf look. congruence. Qed. - + Obligation Tactic := intros ; try match goal with | infer : context [wellinferred _ _ _ -> principal_type _ _ ], wt : wellinferred _ _ _ |- _ => try clear infer ; destruct wt as [T HT] end. - + Definition primitive_constant (tag : Primitive.prim_tag) : option kername := let retro := abstract_env_ext_retroknowledge X in match tag with @@ -301,15 +301,15 @@ Qed. now rewrite <- (abstract_env_ext_retroknowledge_correct (Σ := Σ) X). Qed. - Equations infer (Γ : context) (wfΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) (t : term) + Equations infer (Γ : context) (wfΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) (t : term) (wt : forall Σ (wfΣ : abstract_env_ext_rel X Σ), wellinferred Σ Γ t) : principal_type Γ t by struct t := - infer Γ wfΓ (tRel n) wt with - inspect (option_map (lift0 (S n) ∘ decl_type) (nth_error Γ n)) := + infer Γ wfΓ (tRel n) wt with + inspect (option_map (lift0 (S n) ∘ decl_type) (nth_error Γ n)) := { | exist None _ => ! | exist (Some t) _ => ret t }; - + infer Γ wfΓ (tVar n) wt := !; infer Γ wfΓ (tEvar ev args) wt := !; @@ -343,9 +343,9 @@ Qed. infer Γ wfΓ (tInd ind u) wt with inspect (lookup_ind_decl ind) := { | exist (Checked decl) _ := ret (subst_instance u decl.π2.π1.(ind_type)) | exist (TypeError e) _ := ! }; - + infer Γ wfΓ (tConstruct ind k u) wt with inspect (lookup_ind_decl ind) := - { | exist (Checked decl) _ with inspect (nth_error decl.π2.π1.(ind_ctors) k) := + { | exist (Checked decl) _ with inspect (nth_error decl.π2.π1.(ind_ctors) k) := { | exist (Some cdecl) _ => ret (type_of_constructor decl.π1 cdecl (ind, k) u) | exist None _ => ! } | exist (TypeError e) _ => ! }; @@ -360,7 +360,7 @@ Qed. infer Γ wfΓ (tProj p c) wt with inspect (@lookup_ind_decl p.(proj_ind)) := { | exist (Checked d) _ with inspect (nth_error d.π2.π1.(ind_projs) p.(proj_arg)) := { | exist (Some pdecl) _ with inspect (reduce_to_ind Γ (infer Γ wfΓ c _) _) := - { | exist (Checked_comp indargs) _ => + { | exist (Checked_comp indargs) _ => let ty := pdecl.(proj_type) in ret (subst0 (c :: List.rev (indargs.π2.π2.π1)) (subst_instance indargs.π2.π1 ty)) | exist (TypeError_comp _ _) _ => ! } @@ -407,8 +407,8 @@ Qed. Defined. Next Obligation. - pose (hΣ _ wfΣ). specialize_Σ wfΣ. - inversion wt. + pose (hΣ _ wfΣ). specialize_Σ wfΣ. + inversion wt. sq. constructor ; tea. inversion X0. @@ -421,21 +421,21 @@ Qed. Defined. Next Obligation. - pose (hΣ _ wfΣ). specialize_Σ wfΣ. inversion wt. sq. + pose (hΣ _ wfΣ). specialize_Σ wfΣ. inversion wt. sq. inversion X0 ; subst. constructor ; tea. now eapply infering_sort_isType. Defined. Next Obligation. case t2 as []. intros; cbn. specialize_Σ wfΣ. - inversion wt. + inversion wt. sq. inversion X0 ; subst. now econstructor. Defined. Next Obligation. - pose (hΣ _ wfΣ). specialize_Σ wfΣ. inversion wt. sq. + pose (hΣ _ wfΣ). specialize_Σ wfΣ. inversion wt. sq. inversion X0 ; subst. constructor ; tea. 1: now eapply infering_sort_isType. @@ -444,27 +444,27 @@ Qed. Defined. Next Obligation. cbn; intros; case b'_ty as []. cbn. - specialize_Σ wfΣ. inversion wt. sq. + specialize_Σ wfΣ. inversion wt. sq. inversion X0 ; subst. now econstructor. Defined. Next Obligation. - specialize_Σ wfΣ. inversion wt. sq. + specialize_Σ wfΣ. inversion wt. sq. inversion X0 ; subst. inversion X1. now econstructor. Defined. Next Obligation. - case ty as []. - cbn. specialize_Σ wfΣ. inversion wt. + case ty as []. + cbn. specialize_Σ wfΣ. inversion wt. apply wat_welltyped ; tea. pose (hΣ _ wfΣ). sq. eapply validity, infering_typing ; eauto. Defined. Next Obligation. case ty as []. - cbn. specialize_Σ wfΣ. inversion wt. + cbn. specialize_Σ wfΣ. inversion wt. pose (hΣ _ wfΣ). sq. inversion X0 ; subst. eapply infering_prod_infering in X1 as (?&?&[]); eauto. @@ -472,7 +472,7 @@ Qed. now apply closed_red_red. Defined. Next Obligation. - cbn; intros. case pi as (?&?&[]). + cbn; intros. case pi as (?&?&[]). case ty as []. cbn in *. specialize_Σ wfΣ. pose (hΣ _ wfΣ). inversion wt. sq. inversion X0 ; subst. @@ -500,29 +500,29 @@ Qed. Next Obligation. cbn in *; intros. pose (hΣ _ wfΣ). specialize_Σ wfΣ. inversion wt. sq. - inversion X0; subst. - erewrite <- abstract_env_lookup_correct in e; eauto. - rewrite isdecl in e. inversion e. subst. + inversion X0; subst. + erewrite <- abstract_env_lookup_correct in e; eauto. + rewrite isdecl in e. inversion e. subst. now constructor. Defined. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize_Σ wfΣ. inversion wt. + specialize_Σ wfΣ. inversion wt. inversion X0 ; subst. - clear wildcard. erewrite <- abstract_env_lookup_correct in e; eauto. + clear wildcard. erewrite <- abstract_env_lookup_correct in e; eauto. rewrite isdecl in e. inversion e. Defined. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize_Σ wfΣ. inversion wt. + specialize_Σ wfΣ. inversion wt. inversion X0 ; subst. - clear wildcard. erewrite <- abstract_env_lookup_correct in e; eauto. + clear wildcard. erewrite <- abstract_env_lookup_correct in e; eauto. rewrite isdecl in e. inversion e. Defined. Next Obligation. cbn in *; intros. pose (hΣ _ wfΣ). specialize_Σ wfΣ. inversion wt. sq. - inversion X0; subst. + inversion X0; subst. clear e. destruct decl as (?&?&isdecl'). cbn. @@ -532,15 +532,15 @@ Qed. Defined. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize_Σ wfΣ. inversion wt. + specialize_Σ wfΣ. inversion wt. inversion X0 ; subst. - eapply lookup_ind_decl_complete. 1: eauto. + eapply lookup_ind_decl_complete. 1: eauto. 1: now symmetry. now do 2 eexists. Defined. Next Obligation. - cbn; intros. specialize_Σ wfΣ. inversion wt. sq. + cbn; intros. specialize_Σ wfΣ. inversion wt. sq. inversion X0 ; subst. clear e. destruct decl as (?&?&isdecl'). @@ -553,7 +553,7 @@ Qed. Defined. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize_Σ wfΣ. inversion wt. + specialize_Σ wfΣ. inversion wt. inversion X0 ; subst. clear e. destruct decl as (?&?&isdecl'). @@ -564,25 +564,25 @@ Qed. Defined. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize_Σ wfΣ. inversion wt. + specialize_Σ wfΣ. inversion wt. inversion X0 ; subst. destruct isdecl. - eapply lookup_ind_decl_complete. 1:eauto. + eapply lookup_ind_decl_complete. 1:eauto. 1: now symmetry. now do 2 eexists. Defined. - Next Obligation. exact X_type. Defined. + Next Obligation. exact X_type. Defined. Next Obligation. exact X. Defined. - Next Obligation. - specialize_Σ wfΣ. inversion wt. + Next Obligation. + specialize_Σ wfΣ. inversion wt. inversion X0 ; subst. inversion X1. now econstructor. Defined. - Next Obligation. + Next Obligation. cbn in *. pose proof wt. specialize_Σ wfΣ. destruct infer. - pose (hΣ _ wfΣ). cbn. specialize_Σ wfΣ. sq. + pose (hΣ _ wfΣ). cbn. specialize_Σ wfΣ. sq. eapply infering_typing, validity in s as [] ; eauto. now eexists. Defined. @@ -592,9 +592,9 @@ Qed. cbn in *. intros. set (H := λ (Σ0 : global_env_ext) (wfΣ0 : abstract_env_ext_rel X Σ0), infer_obligations_obligation_26 Γ ci p c brs wt Σ0 - wfΣ0) in indargs. cbn in *. + wfΣ0) in indargs. cbn in *. set (infer _ wfΓ c H) in *. unfold H in *. clear H. - pose proof p0.π2 as p02. + pose proof p0.π2 as p02. destruct indargs as (?&?&?&?). cbn in *. pose proof wt; pose proof wfΓ ; pose proof s as s'. @@ -636,9 +636,9 @@ Qed. cbn in *. intros. set (H := λ (Σ : global_env_ext) (wfΣ : abstract_env_ext_rel X Σ), infer_obligations_obligation_26 Γ ci p c brs wt Σ wfΣ) in a0. - cbn in *. + cbn in *. set (infer _ wfΓ c H) in *. - unfold H in *. clear H e. + unfold H in *. clear H e. destruct p0 as [? i]. cbn in *. pose proof wt; pose proof wfΓ. @@ -649,18 +649,18 @@ Qed. inversion X0 ; subst. eapply infering_ind_infering in i as [? []] ; eauto. do 3 eexists. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. eauto. + Unshelve. eauto. Defined. - Next Obligation. exact X_type. Defined. + Next Obligation. exact X_type. Defined. Next Obligation. exact X. Defined. - Next Obligation. + Next Obligation. specialize_Σ wfΣ. destruct wt. - inversion X0. inversion X1. - now econstructor. + inversion X0. inversion X1. + now econstructor. Defined. Next Obligation. - destruct infer. - pose proof s as s'; pose proof wfΓ as wfΓ'. + destruct infer. + pose proof s as s'; pose proof wfΓ as wfΓ'. specialize_Σ wfΣ. pose (hΣ _ wfΣ); sq. cbn. @@ -670,9 +670,9 @@ Qed. Next Obligation. cbn in *. intros. set (H := λ (Σ0 : global_env_ext) (wfΣ0 : abstract_env_ext_rel X Σ0), - infer_obligations_obligation_32 Γ p c wt Σ0 wfΣ0) in indargs. cbn in *. + infer_obligations_obligation_32 Γ p c wt Σ0 wfΣ0) in indargs. cbn in *. set (infer _ wfΓ c H) in *. unfold H in *. clear H. - pose proof p0.π2 as p02. + pose proof p0.π2 as p02. destruct indargs as (?&?&?&?). destruct d as (?&?&isdecl). clear e. @@ -701,13 +701,13 @@ Qed. now eapply All2_length. Defined. Next Obligation. - cbn in *. - set (H := (λ (Σ0 : global_env_ext) + cbn in *. + set (H := (λ (Σ0 : global_env_ext) (wfΣ0 : abstract_env_ext_rel X Σ0), infer_obligations_obligation_32 Γ p c wt Σ0 wfΣ0)) in a0. - cbn in *. + cbn in *. set (infer _ wfΓ c H) in *. - unfold H in *. clear H e1. + unfold H in *. clear H e1. destruct p0. cbn -[lookup_ind_decl] in *. pose proof wt; pose proof wfΓ. @@ -718,14 +718,14 @@ Qed. eapply infering_ind_infering in s as [? []] ; eauto. apply a0. do 3 eexists. - intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. Unshelve. all: eauto. Defined. Next Obligation. destruct d as (?&?&isdecl). clear e. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize (wt _ wfΣ). destruct wt. inversion X0. + specialize (wt _ wfΣ). destruct wt. inversion X0. destruct H1 as [[] []]. cbn -[lookup_ind_decl nth_error] in *. eapply declared_inductive_inj in isdecl as [] ; tea. @@ -735,7 +735,7 @@ Qed. Next Obligation. cbn -[lookup_ind_decl] in *. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize (wt _ wfΣ). destruct wt. inversion X0. + specialize (wt _ wfΣ). destruct wt. inversion X0. eapply lookup_ind_decl_complete ; eauto. do 2 eexists. exact H1. @@ -744,40 +744,40 @@ Qed. Next Obligation. sq. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize (wt _ wfΣ). destruct wt. inversion X0. + specialize (wt _ wfΣ). destruct wt. inversion X0. subst. intros; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - now constructor. + now constructor. Unshelve. eauto. Qed. Next Obligation. cbn in e. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize (wt _ wfΣ). destruct wt. inversion X0. + specialize (wt _ wfΣ). destruct wt. inversion X0. congruence. Qed. Next Obligation. sq. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize (wt _ wfΣ). destruct wt. inversion X0. + specialize (wt _ wfΣ). destruct wt. inversion X0. subst. intros; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - now constructor. - Unshelve. eauto. + now constructor. + Unshelve. eauto. Qed. Next Obligation. cbn in e. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - specialize (wt _ wfΣ). destruct wt. inversion X0. + specialize (wt _ wfΣ). destruct wt. inversion X0. congruence. Qed. - + Next Obligation. cbn. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. intros. specialize (wt _ wfΣ). destruct wt. - inversion X0; subst. + inversion X0; subst. cbn in eqp. rewrite (primitive_constant_spec _ Σ) // in eqp. rewrite /= -eqp in H0. noconf H0. split. intros; erewrite (abstract_env_ext_irr _ wfΣ0 wfΣ); eauto. @@ -787,14 +787,14 @@ Qed. cbn in *. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. intros. specialize (wt _ wfΣ). destruct wt. - inversion X0; subst. + inversion X0; subst. rewrite (primitive_constant_spec _ Σ) // in e. rewrite /= -e in H0. noconf H0. Qed. - + Definition type_of Γ wfΓ t wt : term := (infer Γ wfΓ t wt). - - Definition principal_typing Σ Γ t P := + + Definition principal_typing Σ Γ t P := forall T, Σ ;;; Γ |- t : T -> Σ ;;; Γ ⊢ P ≤ T. Program Definition type_of_typing Γ t (wt : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ t) : ∑ T, forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ (Σ ;;; Γ |- t : T) × principal_typing Σ Γ t T ∥ := @@ -811,7 +811,7 @@ Qed. Qed. Next Obligation. cbn in *. subst it. intros. pose proof wt as wt'. - destruct (hΣ _ wfΣ) as [wΣ]. + destruct (hΣ _ wfΣ) as [wΣ]. destruct infer as []; cbn. specialize_Σ wfΣ. destruct wt' as [T' HT']. sq. @@ -822,7 +822,7 @@ Qed. eapply infering_checking;tea. 1-2: pcuic. fvs. econstructor; tea. now eapply ws_cumul_pb_forget in HP'. - Defined. + Defined. Lemma squash_isType_welltyped : forall {Σ : global_env_ext} {Γ : context} {T : term}, @@ -830,25 +830,25 @@ Qed. Proof using Type. intros. destruct H. now eapply isType_welltyped. Qed. Opaque type_of_typing. - Equations? sort_of_type (Γ : context) (t : PCUICAst.term) + Equations? sort_of_type (Γ : context) (t : PCUICAst.term) (wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ isType Σ Γ t ∥) : - (∑ u : Universe.t, forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> + (∑ u : Universe.t, forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ Σ ;;; Γ |- t : tSort u ∥) := sort_of_type Γ t wt with (@type_of_typing Γ t _) := - { | T with inspect (reduce_to_sort (X:=X) Γ T.π1 _) := + { | T with inspect (reduce_to_sort (X:=X) Γ T.π1 _) := { | exist (Checked_comp (u; Hu)) hr => (u; _) | exist (TypeError_comp _ _) ns => False_rect _ _ } }. Proof. - eapply squash_isType_welltyped, wt; eauto. - - cbn. + - cbn. specialize (wt _ wfΣ) as [wt]. destruct T as [T HT]. destruct (HT _ wfΣ) as [[Ht _]]. - pose proof (abstract_env_ext_wf _ wfΣ) as [wf]. + pose proof (abstract_env_ext_wf _ wfΣ) as [wf]. eapply validity in Ht. now eapply isType_welltyped. - - clear hr. - pose proof (abstract_env_ext_wf _ H) as [wf]. + - clear hr. + pose proof (abstract_env_ext_wf _ H) as [wf]. specialize (Hu _ H) as [Hred]. cbn in Hred. destruct T as [T HT]. destruct (HT _ H) as [[Ht _]]. cbn in Hred. @@ -867,7 +867,7 @@ Qed. Transparent type_of_typing. Open Scope type_scope. - + Definition map_typing_result {A B} (f : A -> B) (e : typing_result A) : typing_result B := match e with | Checked a => Checked (f a) @@ -880,11 +880,11 @@ Qed. forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ ⊢ type_of Γ _ t _ ≤ T ∥ := type_of_subtype wt := _. Proof. - - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. specialize_Σ wfΣ. case wt as [wt']. apply sq. now exact (typing_wf_local wt'). - - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. specialize_Σ wfΣ. case wt as [wt']. case (hΣ _ wfΣ) as [hΣ']. apply typing_infering in wt'. @@ -898,18 +898,18 @@ Qed. eapply infering_checking ; eauto. + now eapply typing_wf_local. + now eapply type_is_open_term. - + now eapply typing_checking. - Unshelve. all: eauto. + + now eapply typing_checking. + Unshelve. all: eauto. Defined. - (* Note the careful use of squashing here: the principal type is accessible + (* Note the careful use of squashing here: the principal type is accessible computationally but the proof it is principal is squashed (in Prop). The [PCUICPrincipality.principal_type] proof gives an unsquashed version of the same theorem. *) - - Theorem principal_types {Γ t} (wt : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ t) : + + Theorem principal_types {Γ t} (wt : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ t) : ∑ P, ∥ forall T Σ (wfΣ : abstract_env_ext_rel X Σ), Σ ;;; Γ |- t : T -> (Σ ;;; Γ |- t : P) * (Σ ;;; Γ ⊢ P ≤ T) ∥. Proof using nor. - unshelve eexists (infer Γ _ t _); intros. + unshelve eexists (infer Γ _ t _); intros. - destruct (wt _ wfΣ). pose (hΣ _ wfΣ); sq. now eapply typing_wf_local. @@ -918,7 +918,7 @@ Qed. eapply typing_infering in wt' as [? []]. econstructor. eassumption. - - cbn. + - cbn. set (H := (λ (Σ0 : global_env_ext) (wfΣ0 : abstract_env_ext_rel X Σ0), match hΣ Σ0 wfΣ0 with | sq H => @@ -941,15 +941,15 @@ Qed. @sq (All_local_env (lift_typing (@typing cf) Σ) Γ) (@typing_wf_local cf Σ Γ t A x) end - end)). - cbn. + end)). + cbn. set (infer Γ H' t H). clearbody p. - clear H H'. destruct p as [T i]; eauto. + clear H H'. destruct p as [T i]; eauto. cbn. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. intros T' ? ?. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - clear Σ0 wfΣ0. intros. split. + clear Σ0 wfΣ0. intros. split. + apply infering_typing ; eauto. now eapply typing_wf_local. + eapply infering_checking ; eauto. diff --git a/safechecker/theories/PCUICTypeChecker.v b/safechecker/theories/PCUICTypeChecker.v index 45a973f5b..a3f16fdfd 100644 --- a/safechecker/theories/PCUICTypeChecker.v +++ b/safechecker/theories/PCUICTypeChecker.v @@ -43,7 +43,7 @@ Proof. - destruct l ; cbn in * ; auto. eapply IHi ; tea. now inversion Hl. -Qed. +Qed. Lemma subst_global_uctx_invariants {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf_ext Σ} {inst cstrs} {u : Instance.t} : @@ -98,7 +98,7 @@ Proof. split. * destruct l. -- now eapply wf_ext_global_uctx_invariants. - -- cbn in Hcs'. + -- cbn in Hcs'. forward Hcs'. do 2 eexists. constructor. @@ -124,8 +124,8 @@ Proof. Qed. (** It otherwise tries [auto with *], very bad idea. *) -Ltac Coq.Program.Tactics.program_solve_wf ::= - match goal with +Ltac Coq.Program.Tactics.program_solve_wf ::= + match goal with | |- @Wf.well_founded _ _ => auto with subterm wf | |- ?T => match type of T with | Prop => auto @@ -134,7 +134,7 @@ Ltac Coq.Program.Tactics.program_solve_wf ::= Implicit Types (cf : checker_flags) (Σ : global_env_ext). -Lemma declared_global_uctx_global_ext_uctx {l} {Σ : global_env} {univs} : +Lemma declared_global_uctx_global_ext_uctx {l} {Σ : global_env} {univs} : declared l (global_uctx Σ).1 -> declared l (global_ext_uctx (Σ, univs)).1. Proof. @@ -142,7 +142,7 @@ Proof. eapply LevelSet.union_spec. now right. Qed. -Lemma global_uctx_invariants_ext {cf} {Σ : global_env} {wfΣ : wf Σ} {univs} : +Lemma global_uctx_invariants_ext {cf} {Σ : global_env} {wfΣ : wf Σ} {univs} : on_udecl_prop Σ univs -> global_uctx_invariants (global_ext_uctx (Σ, univs)). Proof. @@ -156,11 +156,11 @@ Proof. destruct hx. cbn in H. * now apply ond. * specialize (Hc x H). - destruct x as ((l'&d')&r'). + destruct x as ((l'&d')&r'). now destruct Hc; split; eapply declared_global_uctx_global_ext_uctx. Qed. -Lemma spine_subst_smash_inv {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} +Lemma spine_subst_smash_inv {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ inst Δ s} : wf_local Σ (Γ ,,, Δ) -> spine_subst Σ Γ inst s (smash_context [] Δ) -> @@ -200,7 +200,7 @@ Proof. set (decli' := on_declared_inductive declm). rename declm into decli. destruct decli' as [declm decli']. - pose proof (decli'.(onArity)) as ar. + pose proof (decli'.(onArity)) as ar. rewrite decli'.(ind_arity_eq) in tyargs, ar. hnf in ar. destruct ar as [s' ar]. rewrite -it_mkProd_or_LetIn_app in ar tyargs. @@ -211,10 +211,10 @@ Proof. now eapply spine_subst_smash in sp. Qed. -(* Lemma compare_global_instance_sound {cf Σ} (wfΣ : wf_ext Σ) gr napp +(* Lemma compare_global_instance_sound {cf Σ} (wfΣ : wf_ext Σ) gr napp (Hφ : on_udecl Σ.1 Σ.2) (G : universes_graph) (HG : is_graph_of_uctx G (global_ext_uctx Σ)) : - subrelation (compare_global_instance Σ (check_eqb_universe G) (check_leqb_universe G) gr napp) + subrelation (compare_global_instance Σ (check_eqb_universe G) (check_leqb_universe G) gr napp) (R_global_instance Σ (eq_universe Σ) (leq_universe Σ) gr napp). Proof. eapply reflect_R_global_instance. compare_global_instance_impl; tc; intros x y. - eapply (check_eqb_universe_spec' _ (global_ext_uctx Σ)) => //. @@ -238,7 +238,7 @@ Lemma substitution_wf_local_rel `{checker_flags} {Σ} {wfΣ : wf Σ} {Γ Γ' s rewrite app_context_cons in Ht ; depelim Ht. constructor ; cbn. + eapply IHΔ ; tea. - + rewrite Nat.add_0_r. + + rewrite Nat.add_0_r. eapply isType_substitution ; tea. now rewrite -app_context_assoc. + rewrite Nat.add_0_r. @@ -249,7 +249,7 @@ Lemma substitution_wf_local_rel `{checker_flags} {Σ} {wfΣ : wf Σ} {Γ Γ' s rewrite app_context_cons in Ht ; depelim Ht. constructor ; cbn. + eapply IHΔ ; tea. - + rewrite Nat.add_0_r. + + rewrite Nat.add_0_r. eapply isType_substitution ; tea. now rewrite -app_context_assoc. Qed. @@ -261,20 +261,20 @@ Section Typecheck. Context (X : X_type.π2.π1). - Local Definition heΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : + Local Definition heΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : ∥ wf_ext Σ ∥ := abstract_env_ext_wf _ wfΣ. Local Definition hΣ Σ (wfΣ : abstract_env_ext_rel X Σ) : - ∥ wf Σ ∥ := abstract_env_ext_sq_wf _ _ _ wfΣ. + ∥ wf Σ ∥ := abstract_env_ext_sq_wf _ _ _ wfΣ. Ltac specialize_Σ wfΣ := - repeat match goal with | h : _ |- _ => specialize (h _ wfΣ) end. + repeat match goal with | h : _ |- _ => specialize (h _ wfΣ) end. Local Notation ret := Checked_comp (only parsing). Local Notation raise := (fun e => TypeError_comp e _) (only parsing). Local Notation "x <- c1 ;; c2" := ( - match c1 with + match c1 with | TypeError_comp e absurd => raise e | Checked_comp x => c2 end) @@ -282,38 +282,38 @@ Section Typecheck. Local Notation "e1 ;; e2" := (_ <- e1 ;; e2) (at level 100, right associativity). - + (* We get stack overflow on Qed after Equations definitions when this is transparent *) Opaque reduce_stack_full. - Notation hnf := (hnf (X := X)). + Notation hnf := (hnf (X := X)). Definition conv_pb_relb_gen_proper pb equ equ' eqlu eqlu' : (forall u u', equ u u' = equ' u u') -> (forall u u', eqlu u u' = eqlu' u u') -> - forall u u', - conv_pb_relb_gen pb equ eqlu u u' = + forall u u', + conv_pb_relb_gen pb equ eqlu u u' = conv_pb_relb_gen pb equ' eqlu' u u'. now destruct pb. - Qed. + Qed. - Obligation Tactic := simpl in *; + Obligation Tactic := simpl in *; Tactics.program_simplify; (* try unsquash_wf_env; *) - CoreTactics.equations_simpl; + CoreTactics.equations_simpl; try Tactics.program_solve_wf. - Opaque isconv_term. + Opaque isconv_term. (* replaces convert and convert_leq*) Equations convert (le : conv_pb) Γ t u - (ht : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ t) + (ht : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ t) (hu : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ u) : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ ⊢ t ≤[le] u ∥) := convert le Γ t u ht hu with inspect (eqb_termp_napp_gen le (abstract_env_eq X) (abstract_env_leq X) (abstract_env_compare_global_instance X) 0 t u) := { - | @exist true He := ret _ ; + | @exist true He := ret _ ; | @exist false He with inspect (isconv_term _ X Γ le t ht u hu) := { | @exist ConvSuccess Hc := ret _ ; @@ -324,19 +324,19 @@ Section Typecheck. }}. Next Obligation. unfold eqb_termp_napp_gen in He. pose (heΣ _ wfΣ) as heΣ; sq. - constructor; fvs. specialize_Σ wfΣ. + constructor; fvs. specialize_Σ wfΣ. eapply eqb_term_upto_univ_impl; eauto. - intros. eapply iff_reflect. eapply (abstract_env_compare_universe_correct _ wfΣ Conv); - try eassumption; apply wf_universe_iff; eauto. - - intros. eapply iff_reflect. destruct le; + try eassumption; apply wf_universe_iff; eauto. + - intros. eapply iff_reflect. destruct le; eapply (abstract_env_compare_universe_correct _ wfΣ _); - try eassumption; apply wf_universe_iff; eauto. - - intros. rewrite wf_universeb_instance_forall in H. rewrite wf_universeb_instance_forall in H0. - apply wf_universe_instance_iff in H. - apply wf_universe_instance_iff in H0. + try eassumption; apply wf_universe_iff; eauto. + - intros. rewrite wf_universeb_instance_forall in H. rewrite wf_universeb_instance_forall in H0. + apply wf_universe_instance_iff in H. + apply wf_universe_instance_iff in H0. eapply (abstract_env_compare_global_instance_correct X wfΣ); eauto. - intros. apply X0; now eapply wf_universe_iff. + intros. apply X0; now eapply wf_universe_iff. - destruct ht as [? ht]. eapply typing_wf_universes in ht; eauto. pose proof ht as [? ?]%andb_and; eassumption. - destruct hu as [? hu]. eapply typing_wf_universes in hu; eauto. @@ -346,7 +346,7 @@ Section Typecheck. now symmetry in Hc; eapply isconv_term_sound in Hc. Qed. Next Obligation. - symmetry in Hc. + symmetry in Hc. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. eapply isconv_term_complete in Hc; eauto. @@ -355,7 +355,7 @@ Section Typecheck. Definition wt_decl (Σ : global_env_ext) Γ d := match d with - | {| decl_body := Some b; decl_type := ty |} => + | {| decl_body := Some b; decl_type := ty |} => welltyped Σ Γ ty /\ welltyped Σ Γ b | {| decl_body := None; decl_type := ty |} => welltyped Σ Γ ty @@ -375,7 +375,7 @@ Section Typecheck. pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. eapply validity_wf ; eauto. sq. - now eapply infering_typing. + now eapply infering_typing. Qed. Next Obligation. specialize_Σ wfΣ. sq. @@ -388,22 +388,22 @@ Section Typecheck. eapply absurd. eapply infering_sort_infering in X2; eauto. exists X0. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. eauto. + Unshelve. eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. sq. eapply absurd. inversion X1. - eexists. intros. - erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. eauto. + eexists. intros. + erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. eauto. Qed. - + Equations infer_isType Γ (HΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥wf_local Σ Γ ∥) T : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ isType Σ Γ T ∥) := infer_isType Γ HΓ T := infer_type Γ HΓ T ;; - ret _. + ret _. Next Obligation. pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. now eapply infering_sort_isType. @@ -413,7 +413,7 @@ Section Typecheck. pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. apply absurd. eapply isType_infering_sort in H as [u ?]. - exists u. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + exists u. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. Unshelve. eauto. Qed. @@ -428,7 +428,7 @@ Section Typecheck. eapply validity_wf; auto. sq. now eapply infering_typing. Qed. - Next Obligation. + Next Obligation. specialize_Σ wfΣ. destruct hA; now apply wat_welltyped. Qed. Next Obligation. pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. @@ -446,9 +446,9 @@ Section Typecheck. apply absurd. destruct H. eexists. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. eauto. + Unshelve. eauto. Qed. - + (* Program Definition infer_scheme Γ HΓ t : typing_result_comp (∑ ctx u, ∥ Σ ;;; Γ |- t : mkAssumArity ctx u ∥) := '(T; p) <- infer Γ HΓ t;; @@ -473,7 +473,7 @@ Section Typecheck. Qed. Equations check_context Γ : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) - := + := check_context [] := ret _ ; check_context ({| decl_body := None; decl_type := A |} :: Γ) := HΓ <- check_context Γ ;; @@ -496,7 +496,7 @@ Section Typecheck. intros. now eapply typing_checking. Qed. Next Obligation. - eapply absurd. intros. + eapply absurd. intros. pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. now inversion H ; subst. Qed. @@ -514,14 +514,14 @@ Section Typecheck. pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. eapply absurd. inversion H ; subst. eapply isType_infering_sort in X1 as [] ; tea. - eexists. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. eauto. + eexists. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. eauto. Qed. Next Obligation. eapply absurd. intros. specialize_Σ wfΣ. sq. now inversion H. Qed. - + Lemma sq_wf_local_app {Γ Δ} : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥ -> ∥ wf_local_rel Σ Γ Δ ∥ -> ∥ wf_local Σ (Γ ,,, Δ) ∥. Proof using Type. @@ -536,7 +536,7 @@ Section Typecheck. check_context_rel Γ wfΓ ({| decl_body := None; decl_type := A |} :: Δ) := wfΔ <- check_context_rel Γ wfΓ Δ ;; infer_isType (Γ ,,, Δ) (fun Σ wfΣ => sq_wf_local_app Σ wfΣ (wfΓ Σ wfΣ) (wfΔ Σ wfΣ)) A ;; - ret _ ; + ret _ ; check_context_rel Γ wfΓ ({| decl_body := Some t; decl_type := A |} :: Δ) := wfΔ <- check_context_rel Γ wfΓ Δ ;; @@ -551,7 +551,7 @@ Section Typecheck. eapply checking_typing ; pcuic. Qed. Next Obligation. - apply absurd. intros. + apply absurd. intros. pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. inversion H ; subst ; cbn in *. now eapply typing_checking. @@ -567,7 +567,7 @@ Section Typecheck. now inversion H. Qed. Next Obligation. - specialize_Σ wfΣ. sq. + specialize_Σ wfΣ. sq. now constructor. Qed. Next Obligation. @@ -605,7 +605,7 @@ Section Typecheck. } ; check_ws_cumul_pb_decl le Γ _ _ _ _ := raise (Msg "While checking cumulativity of contexts: declarations do not match"). - Solve All Obligations with + Solve All Obligations with program_simpl; try solve [pose (hΣ _ wfΣ); specialize_Σ wfΣ; sq; intuition]. Next Obligation. pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. @@ -622,17 +622,17 @@ Section Typecheck. now inversion H. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. sq. inversion H ; subst. apply eqb_annot_spec in eqna0. now congruence. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. sq. now inversion H. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. sq. now inversion H. Qed. Next Obligation. @@ -646,13 +646,13 @@ Section Typecheck. now inversion H. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. sq. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ. sq. inversion H ; subst. apply eqb_annot_spec in eqna0. now congruence. Qed. - Lemma context_cumulativity_welltyped {Σ'} (wfΣ' : wf Σ') {le Γ Γ' t} : + Lemma context_cumulativity_welltyped {Σ'} (wfΣ' : wf Σ') {le Γ Γ' t} : welltyped Σ' Γ t -> Σ' ⊢ Γ' ≤[le] Γ -> wf_local Σ' Γ' -> @@ -677,7 +677,7 @@ Section Typecheck. Proof using Type. intros cum; depelim cum; intros; constructor; auto. Qed. - + Lemma conv_decls_irrel_sec Pcmp Σ Γ Γ' d d' : conv_decls Pcmp Σ Γ Γ d d' -> conv_decls Pcmp Σ Γ Γ' d d'. @@ -693,15 +693,15 @@ Section Typecheck. now exists t. Qed. - Lemma cumul_ctx_rel_cons {Pcmp Σ Γ Δ Δ' d d'} (c : cumul_ctx_rel Pcmp Σ Γ Δ Δ') - (p : cumul_decls Pcmp Σ (Γ,,, Δ) (Γ ,,, Δ') d d') : + Lemma cumul_ctx_rel_cons {Pcmp Σ Γ Δ Δ' d d'} (c : cumul_ctx_rel Pcmp Σ Γ Δ Δ') + (p : cumul_decls Pcmp Σ (Γ,,, Δ) (Γ ,,, Δ') d d') : cumul_ctx_rel Pcmp Σ Γ (Δ ,, d) (Δ' ,, d'). Proof using Type. destruct d as [na [b|] ty], d' as [na' [b'|] ty']; try constructor; auto. Qed. - - Lemma ws_cumul_ctx_pb_rel_cons {le Σ Γ Δ Δ' d d'} (c : ws_cumul_ctx_pb_rel le Σ Γ Δ Δ') - (p : ws_cumul_decls le Σ (Γ,,, Δ) d d') : + + Lemma ws_cumul_ctx_pb_rel_cons {le Σ Γ Δ Δ' d d'} (c : ws_cumul_ctx_pb_rel le Σ Γ Δ Δ') + (p : ws_cumul_decls le Σ (Γ,,, Δ) d d') : ws_cumul_ctx_pb_rel le Σ Γ (Δ ,, d) (Δ' ,, d'). Proof using Type. destruct c. split; auto. @@ -709,19 +709,19 @@ Section Typecheck. Qed. Equations check_ws_cumul_ctx (le : conv_pb) Γ Δ Δ' - (wfΔ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ (Γ ,,, Δ) ∥) (wfΔ' : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ (Γ ,,, Δ') ∥) : + (wfΔ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ (Γ ,,, Δ) ∥) (wfΔ' : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ (Γ ,,, Δ') ∥) : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ ws_cumul_ctx_pb_rel le Σ Γ Δ Δ' ∥) := check_ws_cumul_ctx le Γ [] [] _ _ := ret _ ; - + check_ws_cumul_ctx le Γ (decl :: Δ) (decl' :: Δ') wfΔ wfΔ' := check_ws_cumul_ctx le Γ Δ Δ' _ _ ;; check_ws_cumul_pb_decl le (Γ ,,, Δ) decl decl' _ _ ;; ret _ ; - + check_ws_cumul_ctx le Γ _ _ _ _ := raise (Msg "While checking cumulativity of contexts: contexts do not have the same length"). - + Next Obligation. intros; pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. split. @@ -743,7 +743,7 @@ Section Typecheck. specialize_Σ wfΣ. sq. now depelim wfΔ'. Qed. Next Obligation. - specialize_Σ wfΣ. sq. + specialize_Σ wfΣ. sq. depelim wfΔ; simpl. destruct l; eexists; eauto. destruct l; split; eexists; eauto. @@ -775,12 +775,12 @@ Section Typecheck. depelim H. now apply ws_cumul_ctx_pb_rel_app. Qed. - + Equations check_alpha_ws_cumul_ctx Δ Δ' : typing_result_comp (∥ eq_context_gen eq eq Δ Δ' ∥) := check_alpha_ws_cumul_ctx Δ Δ' with inspect (forallb2 (bcompare_decls eqb eqb) Δ Δ') := { - | @exist true e := ret _ ; + | @exist true e := ret _ ; | @exist false e' := raise (Msg "While checking alpha-conversion of contexts: contexts differ") }. Next Obligation. @@ -806,14 +806,14 @@ Section Typecheck. sq. constructor; auto. now exists checkt. Qed. *) - Lemma assumption_context_subst_telescope s k Γ : + Lemma assumption_context_subst_telescope s k Γ : assumption_context Γ -> assumption_context (subst_telescope s k Γ). Proof using Type. rewrite /subst_telescope /mapi. intros ass; generalize 0. induction ass; cbn; constructor; auto. Qed. - - Lemma assumption_context_rev Γ : + + Lemma assumption_context_rev Γ : assumption_context Γ -> assumption_context (List.rev Γ). Proof using Type. intros ass; induction ass; cbn; try constructor; auto. @@ -821,7 +821,7 @@ Section Typecheck. Qed. - Equations check_inst Γ (wfΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) Δ (wfΔ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local_rel Σ Γ (List.rev Δ) ∥) (HΔ : assumption_context Δ) ts : + Equations check_inst Γ (wfΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) Δ (wfΔ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local_rel Σ Γ (List.rev Δ) ∥) (HΔ : assumption_context Δ) ts : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ ctx_inst Σ Γ ts Δ ∥) by struct ts := check_inst Γ _ [] _ _ [] := ret _ ; check_inst Γ wfΓ @@ -869,7 +869,7 @@ Section Typecheck. sq. depelim HΔ. now apply assumption_context_subst_telescope. Qed. Next Obligation. - pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. + pose (hΣ _ wfΣ). specialize_Σ wfΣ. sq. constructor ; tea. apply checking_typing ; auto. eapply All_local_env_app_l in wfΔ. @@ -884,8 +884,8 @@ Section Typecheck. apply typing_checking. now depelim H. Qed. - - Equations check_ws_cumul_pb_terms Γ ts ts' (wts : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ All (welltyped Σ Γ) ts ∥) (wts' : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ All (welltyped Σ Γ) ts' ∥) : + + Equations check_ws_cumul_pb_terms Γ ts ts' (wts : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ All (welltyped Σ Γ) ts ∥) (wts' : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ All (welltyped Σ Γ) ts' ∥) : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ ws_cumul_pb_terms Σ Γ ts ts' ∥) := check_ws_cumul_pb_terms Γ [] [] _ _ := ret _ ; check_ws_cumul_pb_terms Γ (t :: ts) (t' :: ts') wts wts' := @@ -924,7 +924,7 @@ Section Typecheck. apply absurd; intros; specialize_Σ wfΣ; sq. now depelim H. Qed. - + End InferAux. Equations lookup_ind_decl ind @@ -932,7 +932,7 @@ Section Typecheck. ({decl & {body & forall Σ (wfΣ : abstract_env_ext_rel X Σ), declared_inductive (fst Σ) ind decl body}}) := lookup_ind_decl ind with inspect (abstract_env_lookup X ind.(inductive_mind)) := { - | @exist (Some (InductiveDecl decl)) _ + | @exist (Some (InductiveDecl decl)) _ with inspect (nth_error decl.(ind_bodies) ind.(inductive_ind)) := { | @exist (Some body) _ => ret (decl; (body; _)) ; | @exist None _ => raise (UndeclaredInductive ind) @@ -941,41 +941,41 @@ Section Typecheck. }. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ. - erewrite <- abstract_env_lookup_correct in e0; eauto. - depelim X2. - unfold declared_minductive in H. erewrite <- e0 in H. - congruence. + erewrite <- abstract_env_lookup_correct in e0; eauto. + depelim X2. + unfold declared_minductive in H. erewrite <- e0 in H. + congruence. Qed. Next Obligation. - erewrite <- abstract_env_lookup_correct in e; eauto. + erewrite <- abstract_env_lookup_correct in e; eauto. now split. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ. - erewrite <- abstract_env_lookup_correct in e1; eauto. - depelim X2. - unfold declared_minductive in H. erewrite <- e1 in H. - congruence. - Qed. + erewrite <- abstract_env_lookup_correct in e1; eauto. + depelim X2. + unfold declared_minductive in H. erewrite <- e1 in H. + congruence. + Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ. - erewrite <- abstract_env_lookup_correct in e0; eauto. - depelim X2. - unfold declared_minductive in H. erewrite <- e0 in H. + erewrite <- abstract_env_lookup_correct in e0; eauto. + depelim X2. + unfold declared_minductive in H. erewrite <- e0 in H. congruence. - Qed. - - Definition abstract_env_level_mem_forallb {Σ} (wfΣ : abstract_env_ext_rel X Σ) u : + Qed. + + Definition abstract_env_level_mem_forallb {Σ} (wfΣ : abstract_env_ext_rel X Σ) u : forallb (level_mem Σ) u = forallb (abstract_env_level_mem X) u. - Proof using Type. + Proof using Type. induction u; eauto; cbn. - erewrite <- abstract_env_level_mem_correct; eauto. intuition. - Qed. + erewrite <- abstract_env_level_mem_correct; eauto. intuition. + Qed. - Equations check_consistent_instance uctx (wfg : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ global_uctx_invariants (global_ext_uctx (Σ.1, uctx)) ∥) + Equations check_consistent_instance uctx (wfg : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ global_uctx_invariants (global_ext_uctx (Σ.1, uctx)) ∥) u : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), consistent_instance_ext Σ uctx u) := - check_consistent_instance (Monomorphic_ctx) wfg u + check_consistent_instance (Monomorphic_ctx) wfg u with (Nat.eq_dec #|u| 0) := { | left _ := ret _ ; | right _ := (raise (Msg "monomorphic instance should be of length 0")) @@ -990,24 +990,24 @@ Section Typecheck. | exist false e3 := raise (Msg "ctrs not satisfiable") ; | exist true e3 := ret _ }}}}. - Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; eauto. - Qed. Next Obligation. - pose proof (heΣ _ wfΣ) as [[_wfΣ s]]. specialize_Σ wfΣ. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; eauto. + Qed. + Next Obligation. + pose proof (heΣ _ wfΣ) as [[_wfΣ s]]. specialize_Σ wfΣ. assert (forallb (fun l : LevelSet.elt => LevelSet.mem l (global_ext_levels Σ)) u). { symmetry in e2. eapply forallb_All in e2. eapply All_forallb'; tea. intros x; simpl. erewrite <- abstract_env_level_mem_correct; eauto. } - repeat split; eauto. + repeat split; eauto. - sq. unshelve eapply (abstract_env_check_constraints_correct X); eauto. - now apply nor_check_univs. pose proof (abstract_env_ext_wf _ wfΣ) as [HΣ]. + now apply nor_check_univs. pose proof (abstract_env_ext_wf _ wfΣ) as [HΣ]. eapply (subst_global_uctx_invariants (u := u)) in wfg; eauto. apply wfg. solve_all. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; pose proof (heΣ _ wfΣ) as [heΣ]. destruct wfg as [wfg]. suff: (@abstract_env_check_constraints cf _ _ X_type.π2.π2.π1 X (subst_instance_cstrs u cstrs)). @@ -1015,26 +1015,26 @@ Section Typecheck. - intros. erewrite <- abstract_env_check_constraints_correct; eauto. now clear -H. now apply nor_check_univs. - pose proof (abstract_env_ext_wf _ wfΣ) as [HΣ]. + pose proof (abstract_env_ext_wf _ wfΣ) as [HΣ]. eapply (subst_global_uctx_invariants (u := u)) in wfg; eauto. apply wfg. assert (forallb (fun l : LevelSet.elt => LevelSet.mem l (global_ext_levels Σ)) u). { symmetry in e2. eapply forallb_All in e2. eapply All_forallb'; tea. intros x; simpl. erewrite <- abstract_env_level_mem_correct; eauto. } - solve_all. + solve_all. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; pose proof (heΣ _ wfΣ) as [heΣ]. sq. clear -e2 H heΣ wfΣ. - erewrite <- abstract_env_level_mem_forallb in e2; eauto. - now rewrite <- e2 in H. + erewrite <- abstract_env_level_mem_forallb in e2; eauto. + now rewrite <- e2 in H. Qed. Next Obligation. now destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ. Qed. - + Equations check_is_allowed_elimination (u : Universe.t) (wfu : forall Σ (wfΣ : abstract_env_ext_rel X Σ), wf_universe Σ u) (al : allowed_eliminations) : @@ -1050,7 +1050,7 @@ Section Typecheck. | @exist true _ := ret _ ; | @exist false _ := raise (Msg "Cannot eliminate over this sort") }; - check_is_allowed_elimination u wfu IntoSetPropSProp + check_is_allowed_elimination u wfu IntoSetPropSProp with inspect (is_propositional u || abstract_env_eq X u Universe.type0) := { | @exist true _ := ret _ ; | @exist false _ := raise (Msg "Cannot eliminate over this sort") @@ -1070,7 +1070,7 @@ Section Typecheck. eapply abstract_env_compare_universe_correct in e; eauto using wf_universe_type0. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; pose proof (heΣ _ wfΣ) as [heΣ]. sq. move: (heΣ) => /wf_ext_consistent [v Hv]. symmetry in e0; toProp e0; destruct e0 as [e1 e0]. @@ -1078,8 +1078,8 @@ Section Typecheck. apply diff_false_true. rewrite -e0. eapply abstract_env_compare_universe_correct; eauto using wf_universe_type0. Qed. - - Notation wt_brs Γ ci mdecl idecl p ptm ctors brs n := + + Notation wt_brs Γ ci mdecl idecl p ptm ctors brs n := (forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ All2i (fun i cdecl br => let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in eq_context_upto_names br.(bcontext) (cstr_branch_context ci mdecl cdecl) × @@ -1091,7 +1091,7 @@ Section Typecheck. (Γ : context) (wfΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) (ps : Universe.t) (ci : case_info) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (p : predicate term) (args : list term). - + Context (isdecl : forall Σ (wfΣ : abstract_env_ext_rel X Σ), declared_inductive Σ ci mdecl idecl). Context (hty : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ isType Σ Γ (mkApps (tInd ci (puinst p)) (pparams p ++ args)) ∥). Context (wfp : wf_predicate mdecl idecl p). @@ -1100,9 +1100,9 @@ Section Typecheck. Context (ptm := it_mkLambda_or_LetIn predctx (preturn p)). Context (hpctx : ∥ eq_context_upto_names (pcontext p) (ind_predicate_context ci mdecl idecl) ∥). - + Lemma branch_helper n cdecl ctors br - (isdecl' : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Alli (fun i cdecl => declared_constructor Σ (ci, i) mdecl idecl cdecl) n (cdecl :: ctors) ∥) : + (isdecl' : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Alli (fun i cdecl => declared_constructor Σ (ci, i) mdecl idecl cdecl) n (cdecl :: ctors) ∥) : ∥ eq_context_gen eq eq (bcontext br) (cstr_branch_context ci mdecl cdecl) ∥ -> forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_branch cdecl br × let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm n cdecl in @@ -1127,12 +1127,12 @@ Section Typecheck. Obligation Tactic := intros. Equations check_branches (n : nat) (ctors : list constructor_body) - (brs : list (branch term)) + (brs : list (branch term)) (isdecl : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Alli (fun i cdecl => declared_constructor Σ (ci, i) mdecl idecl cdecl) n ctors ∥) - : typing_result_comp (wt_brs Γ ci mdecl idecl p ptm ctors brs n) by struct brs := + : typing_result_comp (wt_brs Γ ci mdecl idecl p ptm ctors brs n) by struct brs := check_branches n [] [] i := ret _ ; - + check_branches n (cdecl :: cdecls) (br :: brs) i := let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm n cdecl in check_eq_bcontext <- @@ -1140,19 +1140,19 @@ Section Typecheck. bdcheck infer (Γ ,,, brctxty.1) _ br.(bbody) brctxty.2 _ ;; check_branches (S n) cdecls brs _ ;; ret _ ; - + check_branches n _ _ _ := raise (Msg "wrong number of branches"). Next Obligation. sq. now constructor. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; sq. inversion H. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; sq. inversion H. Qed. @@ -1190,8 +1190,8 @@ Section Typecheck. now depelim H. Qed. Next Obligation. - apply absurd; intros. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; + apply absurd; intros. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; sq. depelim H. apply All2_fold_All2. @@ -1219,7 +1219,7 @@ Section Typecheck. wf_branch cdecl br. Proof using Type. intros e. - do 2 red. + do 2 red. eapply eq_context_gen_binder_annot in e. rewrite /cstr_branch_context in e. now do 3 eapply (proj1 (eq_annots_fold _ _ _)) in e. @@ -1259,7 +1259,7 @@ Section Typecheck. check_mfix_types mfix ;; ret _. Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ; sq. constructor ; tea. exists s. now apply infering_sort_typing. @@ -1269,15 +1269,15 @@ Section Typecheck. now depelim H. Qed. Next Obligation. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; - pose proof (heΣ _ wfΣ) as [heΣ]; specialize_Σ wfΣ. sq. - depelim H. - apply absurd. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; + pose proof (heΣ _ wfΣ) as [heΣ]; specialize_Σ wfΣ. sq. + depelim H. + apply absurd. apply isType_infering_sort in i as [u ?]; tea. - exists u. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. eauto. + exists u. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. eauto. Qed. - + Equations check_mfix_bodies (mfix : mfixpoint term) (wf_types : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ All (fun x => isType Σ Γ (dtype x)) mfix ∥) @@ -1295,18 +1295,18 @@ Section Typecheck. ret _. Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ; sq. apply isType_lift ; eauto. - len. - rewrite skipn_all_app. now depelim wf_types. Qed. Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ; sq. now depelim wf_types. Qed. Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ; sq. constructor ; tea. Qed. Next Obligation. @@ -1422,7 +1422,7 @@ Section Typecheck. let chop_args := chop ci.(ci_npar) args in let params := chop_args.1 in let indices := chop_args.2 in cu <- check_consistent_instance (ind_universes mdecl) _ p.(puinst) ;; - check_eq_true (abstract_env_compare_global_instance X (abstract_env_leq X) (IndRef ind') + check_eq_true (abstract_env_compare_global_instance X (abstract_env_leq X) (IndRef ind') #|args| u p.(puinst)) (Msg "invalid universe annotation on case, not larger than the discriminee's universes") ;; wt_params <- check_inst infer Γ HΓ (List.rev (smash_context [] (ind_params mdecl))@[p.(puinst)]) _ _ p.(pparams) ;; @@ -1503,21 +1503,21 @@ Section Typecheck. (* tSort *) Next Obligation. specialize_Σ wfΣ; sq. - symmetry in e. - erewrite <- abstract_env_ext_wf_universeb_correct in e; eauto. + symmetry in e. + erewrite <- abstract_env_ext_wf_universeb_correct in e; eauto. eapply (elimT wf_universe_reflect) in e. sq; econstructor; tas. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ; sq. - inversion X1 ; subst. erewrite <- abstract_env_ext_wf_universeb_correct in e0; eauto. - move: H0 e0 => /wf_universe_reflect -> //. + inversion X1 ; subst. erewrite <- abstract_env_ext_wf_universeb_correct in e0; eauto. + move: H0 e0 => /wf_universe_reflect -> //. Qed. (* tProd *) Next Obligation. (* intros Γ HΓ t na A B Heq_t [s ?]; *) - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ. sq; econstructor ; tea. now eapply infering_sort_isType. Qed. @@ -1528,42 +1528,42 @@ Section Typecheck. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ; sq. inversion X1; subst. apply absurd. - eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ; sq. inversion X1; subst. apply absurd. - eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. (* tLambda *) Next Obligation. (* intros Γ HΓ t0 na A t Heq_t [s ?]; *) - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ. sq; econstructor; tea. now eapply infering_sort_isType. Qed. Next Obligation. (* intros Γ HΓ t0 na A t Heq_t [s ?] [B ?]; *) - cbn; pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ. + cbn; pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ. sq; econstructor; eassumption. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ; sq. inversion X1; subst. apply absurd. - eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ; sq. inversion X1; subst. apply absurd. - eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. (* tLetIn *) Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ. sq; econstructor; tea. eapply infering_sort_typing ; eauto. Qed. @@ -1580,32 +1580,32 @@ Section Typecheck. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ; sq. inversion X1; subst. apply absurd. - eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ; sq. inversion X1; subst. apply absurd. - eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ; sq. inversion X1; subst. apply absurd. - eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + eexists. intros. sq. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. (* tApp *) Next Obligation. cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. - specialize_Σ wfΣ ; sq. + specialize_Σ wfΣ ; sq. eapply validity_wf ; eauto. sq. - now apply infering_typing. + now apply infering_typing. Qed. Next Obligation. cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. - specialize_Σ wfΣ ; sq. + specialize_Σ wfΣ ; sq. eapply infering_typing, type_reduction_closed, validity in X3. 2-4: eauto. destruct X3 as [s HH]. @@ -1614,14 +1614,14 @@ Section Typecheck. eexists. eassumption. Qed. Next Obligation. - cbn in *; specialize_Σ wfΣ ; sq. + cbn in *; specialize_Σ wfΣ ; sq. econstructor ; tea. econstructor ; tea. now apply closed_red_red. Qed. Next Obligation. - cbn in *. apply absurd; intros. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + cbn in *. apply absurd; intros. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. inversion X1 ; subst. assert (is_open_term Γ A). { @@ -1640,7 +1640,7 @@ Section Typecheck. apply into_ws_cumul_pb ; tea. - fvs. - now eapply type_is_open_term, infering_typing. - } + } etransitivity. 2: now eapply red_ws_cumul_pb_inv. now eapply red_ws_cumul_pb. @@ -1648,51 +1648,51 @@ Section Typecheck. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. cbn in *. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. - inversion X1 ; subst. apply absurd. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + inversion X1 ; subst. apply absurd. eapply infering_prod_infering in X2 as (A'&B'&[]) ; eauto. - do 3 eexists. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + do 3 eexists. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. cbn in *. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. inversion X1 ; subst. apply absurd. inversion X2. eexists. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. eauto. + Unshelve. eauto. Qed. - + (* tConst *) Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. eapply global_uctx_invariants_ext. - symmetry in HH. erewrite <- abstract_env_lookup_correct in HH; eauto. + symmetry in HH. erewrite <- abstract_env_lookup_correct in HH; eauto. now apply (weaken_lookup_on_global_env' _ _ _ (heΣ : wf _) HH). Qed. Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. constructor; try assumption. - symmetry in HH. erewrite <- abstract_env_lookup_correct in HH; eauto. + symmetry in HH. erewrite <- abstract_env_lookup_correct in HH; eauto. Qed. Next Obligation. - apply absurd; intros. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. - erewrite <- abstract_env_lookup_correct in HH; eauto. + apply absurd; intros. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + erewrite <- abstract_env_lookup_correct in HH; eauto. inversion X1. unfold declared_constant in isdecl. - rewrite <- HH in isdecl. inversion isdecl. now subst. + rewrite <- HH in isdecl. inversion isdecl. now subst. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. cbn in *. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. - inversion X1 ; subst. erewrite <- abstract_env_lookup_correct in e0; eauto. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + inversion X1 ; subst. erewrite <- abstract_env_lookup_correct in e0; eauto. rewrite isdecl in e0. congruence. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. cbn in *. - pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. inversion X1 ; subst. erewrite <- abstract_env_lookup_correct in e0; eauto. rewrite isdecl in e0. congruence. @@ -1700,7 +1700,7 @@ Section Typecheck. (* tInd *) Next Obligation. - cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. eapply global_uctx_invariants_ext. eapply (weaken_lookup_on_global_env' _ _ _ (heΣ : wf _) (proj1 X1)). Qed. @@ -1708,39 +1708,39 @@ Section Typecheck. cbn in *; specialize_Σ wfΣ ; sq; econstructor; eassumption. Qed. Next Obligation. - apply absurd. intros. cbn in *. specialize_Σ wfΣ ; sq. + apply absurd. intros. cbn in *. specialize_Σ wfΣ ; sq. inversion X1 ; subst. epose proof (H := declared_inductive_unique_sig isdecl X3). now injection H. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. inversion X1 ; subst. apply absurd. do 2 eexists. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. eauto. + Unshelve. eauto. Qed. (* tConstruct *) Next Obligation. - cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. eapply global_uctx_invariants_ext. eapply (weaken_lookup_on_global_env' _ _ _ (heΣ : wf _) (proj1 decl)). Qed. Next Obligation. - cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. econstructor; tea. split ; tea. now symmetry. Qed. Next Obligation. - apply absurd. intros; cbn in *. specialize_Σ wfΣ ; sq. + apply absurd. intros; cbn in *. specialize_Σ wfΣ ; sq. inversion X1 ; subst. epose proof (H := declared_inductive_unique_sig isdecl decl). now injection H. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. inversion X1 ; subst. epose proof (H := declared_inductive_unique_sig isdecl decl). injection H. @@ -1751,27 +1751,27 @@ Section Typecheck. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. inversion X1 ; subst. apply absurd. do 2 eexists. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. exact isdecl. - Unshelve. eauto. + Unshelve. eauto. Qed. (* tCase *) - Next Obligation. - cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + Next Obligation. + cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. eapply infering_typing, validity in X0 as []; eauto. eexists; eauto using validity_wf. Qed. Next Obligation. - cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. eapply global_uctx_invariants_ext. eapply (weaken_lookup_on_global_env' _ _ _ (heΣ : wf _) (proj1 X1)). Qed. Next Obligation. rewrite List.rev_involutive. - cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. eapply wf_rel_weak ; eauto. rewrite subst_instance_smash ; eapply wf_local_smash_context. now eapply on_minductive_wf_params. @@ -1781,7 +1781,7 @@ Section Typecheck. apply assumption_context_subst_instance, smash_context_assumption_context; constructor. Qed. Next Obligation. - cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. apply eqb_eq in i. subst I. apply eqb_eq in i0. rewrite chop_firstn_skipn -i0 /=. @@ -1791,15 +1791,15 @@ Section Typecheck. eapply spine_subst_wt_terms in s. eapply All_impl; tea. intros ? []; auto. now exists x0. Qed. - + Next Obligation. cbn in *. specialize_Σ wfΣ; sq. now eapply ctx_inst_wt. Qed. - + Next Obligation. (*TODO: factor*) - cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. + cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. apply eqb_eq in i. subst I. eapply eqb_eq in i0. rewrite chop_firstn_skipn -i0 /=. @@ -1828,7 +1828,7 @@ Section Typecheck. now rewrite -(declared_minductive_ind_npars X1). * len. rewrite skipn_all_app_eq //. - eapply spine_subst_smash in s0. + eapply spine_subst_smash in s0. pose proof (subslet_length s0). len in H. len. now eapply spine_subst_smash. * len. @@ -1854,7 +1854,7 @@ Section Typecheck. rewrite -(subst_context_smash_context _ _ []). rewrite -(spine_subst_inst_subst X4). rewrite - !smash_context_subst /= !subst_context_nil. - erewrite <- abstract_env_compare_global_instance_correct in i1; eauto. + erewrite <- abstract_env_compare_global_instance_correct in i1; eauto. 2: intros; eapply iff_reflect; eapply (abstract_env_compare_universe_correct _ wfΣ _); try eassumption; apply wf_universe_iff; eauto. @@ -1862,7 +1862,7 @@ Section Typecheck. 2: { eapply consistent_instance_ext_wf; eauto. } eapply (inductive_cumulative_indices X1); tea. Qed. - + Obligation Tactic := idtac. Next Obligation. intros. simpl in *. clearbody isty. @@ -1872,8 +1872,8 @@ Section Typecheck. destruct d as [mdecl [idecl isdecl]]. cbn in *. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. apply eqb_eq in i. subst ind'. eapply eqb_eq in i0. eapply eq_context_gen_wf_predicate; tea. @@ -1882,12 +1882,12 @@ Section Typecheck. eapply infering_typing, type_reduction_closed, validity, isType_mkApps_Ind_inv in cty as [pars [argsub []]]; eauto. now rewrite chop_firstn_skipn /=. - Qed. + Qed. Next Obligation. intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. now eapply wf_case_predicate_context. Qed. @@ -1895,35 +1895,35 @@ Section Typecheck. intros. simpl in *. clearbody isty wfp. destruct ps as [u' pty] ; cbn. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. eapply isType_Sort_inv, validity, infering_sort_typing. 3: eapply wf_case_predicate_context. all: eauto. Qed. - + Next Obligation. intros. now sq. Qed. Next Obligation. intros. cbn in *. - destruct ps ; cbn in *. - cbn in *. specialize_Σ wfΣ ; now sq. + destruct ps ; cbn in *. + cbn in *. specialize_Σ wfΣ ; now sq. Qed. Next Obligation. intros. cbn in *. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. now eapply All2_fold_All2 in check_wfpctx_conv. Qed. Next Obligation. intros; cbn in *. clearbody isty wfp. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. eapply forall_nth_error_Alli. now auto. Qed. @@ -1935,9 +1935,9 @@ Section Typecheck. destruct I as [ind' [u [args s]]]. destruct d as [mdecl [idecl isdecl]]. destruct ps as [ps ?]. - cbn in *. intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. intros. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. apply eqb_eq in i. subst ind'. eapply eqb_eq in i0. rewrite /indices /chop_args chop_firstn_skipn /=. @@ -1946,7 +1946,7 @@ Section Typecheck. red. eapply All2_Forall2. clear - check_brs. induction check_brs; constructor; auto. - destruct r0. + destruct r0. solve_all. eapply eq_context_gen_wf_branch. now eapply All2_fold_All2. @@ -1960,7 +1960,7 @@ Section Typecheck. eapply ctx_inst_smash. now rewrite subst_instance_smash /= in wt_params. - now eapply negbTE. - - erewrite <- abstract_env_compare_global_instance_correct in i1; eauto. + - erewrite <- abstract_env_compare_global_instance_correct in i1; eauto. 1: intros; eapply iff_reflect; eapply (abstract_env_compare_universe_correct _ wfΣ Cumul); try eassumption; apply wf_universe_iff; eauto. @@ -2000,10 +2000,10 @@ Section Typecheck. destruct I as [ind' [u [args s]]]. destruct d as [mdecl [idecl isdecl]]. destruct ps as [ps ?]. - cbn in *. apply absurd. intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ. - destruct X0 as [? [ty]]; eauto. + cbn in *. apply absurd. intros. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. eapply declared_inductive_inj in isdecl as []; tea. subst. sq. @@ -2023,13 +2023,13 @@ Section Typecheck. destruct I as [ind' [u [args s']]]. destruct d as [mdecl [idecl isdecl]]. destruct ps as [ps ?]. - cbn in *. apply absurd. intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ. - destruct X0 as [? [ty]]; eauto. + cbn in *. apply absurd. intros. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. eapply declared_inductive_inj in isdecl as []; tea. - subst. sq. + subst. sq. eapply infering_sort_sort in s as <- ; eauto. now eapply wf_case_predicate_context. Qed. @@ -2041,16 +2041,16 @@ Section Typecheck. destruct I as [ind' [u [args s]]]. destruct d as [mdecl [idecl isdecl]]. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - destruct X0 as [? [ty]]; eauto. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. eapply declared_inductive_inj in isdecl as []; tea. subst. - apply absurd. - - eexists. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + apply absurd. + + eexists. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Next Obligation. @@ -2060,9 +2060,9 @@ Section Typecheck. destruct I as [ind' [u [args s]]]. destruct d as [mdecl [idecl isdecl]]. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - destruct X0 as [? [ty]]; eauto. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. eapply declared_inductive_inj in isdecl as []; tea. subst. @@ -2077,10 +2077,10 @@ Section Typecheck. subst ind' u args mdecl idecl isdecl. destruct I as [ind' [u [args s]]]. destruct d as [mdecl [idecl isdecl]]. - cbn in *. apply absurd. intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ. - destruct X0 as [? [ty]]; eauto. + cbn in *. apply absurd. intros. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. eapply declared_inductive_inj in isdecl as []; tea. subst. @@ -2102,17 +2102,17 @@ Section Typecheck. now eapply Forall_firstn, All_Forall, closed_red_terms_open_left. - now eapply All_forallb, ctx_inst_open_terms. Qed. - + Next Obligation. intros. destruct cty as [A cty]. subst ind' u args mdecl idecl isdecl. destruct I as [ind' [u [args s]]]. destruct d as [mdecl [idecl isdecl]]. - cbn in *. apply absurd. intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ. - destruct X0 as [? [ty]]; eauto. + cbn in *. apply absurd. intros. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. eapply declared_inductive_inj in isdecl as []; tea. subst. @@ -2130,14 +2130,14 @@ Section Typecheck. destruct d as [mdecl [idecl isdecl]]. cbn in *. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - destruct X0 as [? [ty]]; eauto. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. eapply declared_inductive_inj in isdecl as []; tea. subst. apply absurd. - erewrite <- abstract_env_compare_global_instance_correct; eauto. + erewrite <- abstract_env_compare_global_instance_correct; eauto. - eapply infering_ind_ind in X0 as [args'' []]. 2-3: now auto. 2: now econstructor ; tea ; apply closed_red_red. @@ -2145,9 +2145,9 @@ Section Typecheck. erewrite All2_length. 2: eassumption. erewrite <- All2_length ; tea. - - intros. eapply iff_reflect. + - intros. eapply iff_reflect. eapply (abstract_env_compare_universe_correct _ wfΣ Cumul); - try eassumption; apply wf_universe_iff; eauto. + try eassumption; apply wf_universe_iff; eauto. - apply/wf_universe_instanceP. rewrite -wf_universeb_instance_forall. assert (tyu : isType Σ Γ (mkApps (tInd ind' u) args)). @@ -2172,9 +2172,9 @@ Section Typecheck. destruct I as [ind' [u [args s]]]. destruct d as [mdecl [idecl isdecl]]. cbn in *. apply absurd; intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - destruct X0 as [? [ty]]; eauto. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. eapply declared_inductive_inj in isdecl as []; tea. now subst. @@ -2188,9 +2188,9 @@ Section Typecheck. destruct d as [mdecl [idecl isdecl]]. cbn in *. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - destruct X0 as [? [ty]]; eauto. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. eapply declared_inductive_inj in isdecl as []; tea. subst. @@ -2206,9 +2206,9 @@ Section Typecheck. destruct d as [mdecl [idecl isdecl]]. cbn in *. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - destruct X0 as [? [ty]]; eauto. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. eapply declared_inductive_inj in isdecl as []; tea. subst. @@ -2220,13 +2220,13 @@ Section Typecheck. intros. destruct cty as [A cty]. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - destruct X0 as [? [ty]]; eauto. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. apply absurd. - do 2 eexists. intros; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + do 2 eexists. intros; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Next Obligation. @@ -2235,9 +2235,9 @@ Section Typecheck. subst ind' u args. destruct I as [ind' [u [args s]]]. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - destruct X0 as [? [ty]]; eauto. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. cbn in *. apply absurd. @@ -2251,21 +2251,21 @@ Section Typecheck. intros. destruct cty as [A cty]. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - destruct X0 as [? [ty]]; eauto. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. cbn in *. apply absurd. inversion X0 ; subst. apply into_closed_red in X8. 2: fvs. - 2: now eapply type_is_open_term, infering_typing. + 2: now eapply type_is_open_term, infering_typing. eapply infering_unique in cty as [T'' []]; eauto. eapply closed_red_confluence in X8 as [? [? r]] ; tea. eapply invert_red_mkApps_tInd in r as [? []]; subst. do 3 eexists. - sq. intros; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + sq. intros; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. sq. now etransitivity. Unshelve. eauto. Qed. @@ -2273,34 +2273,34 @@ Section Typecheck. Next Obligation. intros. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - destruct X0 as [? [ty]]; eauto. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. + destruct X0 as [? [ty]]; eauto. inversion ty ; subst. cbn in *. sq. apply absurd. inversion X0. - eexists ; sq. intros ; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + eexists ; sq. intros ; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Obligation Tactic := Program.Tactics.program_simplify ; eauto 2. (* tProj *) - Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - eapply validity_wf ; eauto. sq. - now eapply infering_typing. + Next Obligation. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. + eapply validity_wf ; eauto. sq. + now eapply infering_typing. Qed. Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. pose proof (on_declared_inductive decl) as [onmib oni]. eapply onProjections in oni. destruct ind_ctors as [|? []] eqn:hctors => //. - + eapply infer_Proj with (pdecl := pdecl). - split. split. eassumption. cbn. rewrite hctors. reflexivity. split. symmetry; eassumption. cbn in *. @@ -2331,8 +2331,8 @@ Section Typecheck. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. apply absurd. inversion X1. subst. @@ -2343,8 +2343,8 @@ Section Typecheck. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. apply absurd. apply/eqb_specT. cbn in *. @@ -2358,8 +2358,8 @@ Section Typecheck. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. apply absurd. inversion X1 ; subst. inversion X3 ; subst. @@ -2372,22 +2372,22 @@ Section Typecheck. do 3 eexists. sq. intros ; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. sq. now etransitivity. - Unshelve. eauto. + Unshelve. eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. apply absurd. inversion X1 ; subst. inversion X2 ; subst. - do 2 eexists. intros ; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. + do 2 eexists. intros ; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. all: eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. inversion X1 ; subst. eapply declared_inductive_inj in decl as []. 2: exact H1. @@ -2397,83 +2397,83 @@ Section Typecheck. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. inversion X1 ; subst. apply absurd. do 2 eexists. intros. intros ; erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - exact H1. - Unshelve. eauto. + exact H1. + Unshelve. eauto. Qed. - Definition abstract_check_recursivity_kind Finite a Σ (wfΣ: abstract_env_ext_rel X Σ): + Definition abstract_check_recursivity_kind Finite a Σ (wfΣ: abstract_env_ext_rel X Σ): check_recursivity_kind (abstract_env_lookup X) a Finite = check_recursivity_kind (lookup_env Σ) a Finite. Proof using Type. - unfold check_recursivity_kind. + unfold check_recursivity_kind. erewrite <- abstract_env_lookup_correct; eauto. Qed. - Definition abstract_wf_fixpoint mfix Σ (wfΣ: abstract_env_ext_rel X Σ): + Definition abstract_wf_fixpoint mfix Σ (wfΣ: abstract_env_ext_rel X Σ): wf_fixpoint_gen (abstract_env_lookup X) mfix = wf_fixpoint Σ mfix. Proof using Type. unfold wf_fixpoint, wf_fixpoint_gen. destruct (map_option_out (map check_one_fix mfix)); simpl; eauto. induction l; eauto. - erewrite abstract_check_recursivity_kind; eauto. - Qed. + erewrite abstract_check_recursivity_kind; eauto. + Qed. - Definition abstract_wf_cofixpoint mfix Σ (wfΣ: abstract_env_ext_rel X Σ): + Definition abstract_wf_cofixpoint mfix Σ (wfΣ: abstract_env_ext_rel X Σ): wf_cofixpoint_gen (abstract_env_lookup X) mfix = wf_cofixpoint Σ mfix. Proof using Type. unfold wf_cofixpoint, wf_cofixpoint_gen. destruct (map_option_out (map check_one_cofix mfix)); simpl; eauto. induction l; eauto. - erewrite abstract_check_recursivity_kind; eauto. - Qed. + erewrite abstract_check_recursivity_kind; eauto. + Qed. (* tFix *) Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. + pose proof (heΣ _ wfΣ) as [heΣ]. cbn in *. specialize_Σ wfΣ ; sq. now eapply All_mfix_wf. Qed. Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. + pose proof (heΣ _ wfΣ) as [heΣ]. cbn in *. specialize_Σ wfΣ ; sq. - unfold abstract_env_fixguard in guarded. - erewrite <- abstract_env_guard_correct in guarded; eauto. + unfold abstract_env_fixguard in guarded. + erewrite <- abstract_env_guard_correct in guarded; eauto. constructor; auto. eapply All_impl ; tea. intros. now apply isType_infering_sort. - erewrite abstract_wf_fixpoint in wffix; eauto. + erewrite abstract_wf_fixpoint in wffix; eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. - apply absurd. erewrite abstract_wf_fixpoint; eauto. + cbn in *. specialize_Σ wfΣ ; sq. + apply absurd. erewrite abstract_wf_fixpoint; eauto. now inversion X1. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. apply absurd. unfold abstract_env_fixguard. - erewrite <- abstract_env_guard_correct; eauto. + erewrite <- abstract_env_guard_correct; eauto. now inversion X1. Qed. Next Obligation. apply absurd; intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. now inversion X1. Qed. - Next Obligation. - apply absurd; intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + Next Obligation. + apply absurd; intros. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. inversion X1 ; subst. eapply All_impl. 1: eexact X2. @@ -2482,50 +2482,50 @@ Section Typecheck. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. inversion X1 ; subst. congruence. Qed. (* tCoFix *) Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. + pose proof (heΣ _ wfΣ) as [heΣ]. cbn in *. specialize_Σ wfΣ ; sq. now eapply All_mfix_wf. Qed. Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. + pose proof (heΣ _ wfΣ) as [heΣ]. cbn in *. specialize_Σ wfΣ ; sq. unfold abstract_env_cofixguard in guarded. - erewrite <- abstract_env_guard_correct in guarded; eauto. + erewrite <- abstract_env_guard_correct in guarded; eauto. constructor; auto. eapply All_impl ; tea. intros. now apply isType_infering_sort. - erewrite abstract_wf_cofixpoint in wfcofix; eauto. + erewrite abstract_wf_cofixpoint in wfcofix; eauto. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. - apply absurd. erewrite abstract_wf_cofixpoint; eauto. + cbn in *. specialize_Σ wfΣ ; sq. + apply absurd. erewrite abstract_wf_cofixpoint; eauto. now inversion X1. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. - apply absurd. unfold abstract_env_cofixguard. - erewrite <- abstract_env_guard_correct; eauto. + cbn in *. specialize_Σ wfΣ ; sq. + apply absurd. unfold abstract_env_cofixguard. + erewrite <- abstract_env_guard_correct; eauto. now inversion X1. Qed. Next Obligation. apply absurd; intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. now inversion X1. Qed. - Next Obligation. - apply absurd; intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + Next Obligation. + apply absurd; intros. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. inversion X1 ; subst. eapply All_impl. 1: eexact X2. @@ -2534,7 +2534,7 @@ Section Typecheck. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. inversion X1 ; subst. congruence. Qed. @@ -2542,14 +2542,14 @@ Section Typecheck. eapply eqb_eq in i. eapply eqb_eq in i0. rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in HH. split. econstructor. rewrite eqp. - now rewrite -primitive_constant_spec. red. - now rewrite -HH. + now rewrite -primitive_constant_spec. red. + now rewrite -HH. destruct (cst_type d) eqn:hty => //. exists u. split => //. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. depelim X1. eapply eqb_eq in i. eapply eqb_eq in i0. rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in HH. @@ -2558,10 +2558,10 @@ Section Typecheck. symmetry in HH. rewrite /declared_constant in d0. rewrite d0 in HH; noconf HH. destruct p1 as [s' []]. rewrite H in absurd. now apply absurd. - Qed. + Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. depelim X1. eapply eqb_eq in i. rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in HH. @@ -2575,7 +2575,7 @@ Section Typecheck. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. depelim X1. rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in HH. rewrite (primitive_constant_spec _ _ wfΣ) in eqp. @@ -2587,7 +2587,7 @@ Section Typecheck. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. depelim X1. rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in e0. rewrite (primitive_constant_spec _ _ wfΣ) in eqp. @@ -2598,7 +2598,7 @@ Section Typecheck. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. depelim X1. rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in e0. rewrite (primitive_constant_spec _ _ wfΣ) in eqp. @@ -2606,12 +2606,12 @@ Section Typecheck. symmetry in e0. rewrite /declared_constant in d. rewrite e0 in d; noconf d. Qed. - + Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - cbn in *. specialize_Σ wfΣ ; sq. + cbn in *. specialize_Σ wfΣ ; sq. depelim X1. - rewrite (primitive_constant_spec _ _ wfΣ) in e0. + rewrite (primitive_constant_spec _ _ wfΣ) in e0. unfold prim_val_tag in e1. congruence. Qed. @@ -2624,20 +2624,20 @@ Section Typecheck. bdcheck infer Γ HΓ t A _ ;; ret _. Next Obligation. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. now apply checking_typing. Qed. Next Obligation. - apply absurd; intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + apply absurd; intros. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. now apply typing_checking. Qed. Next Obligation. - apply absurd; intros. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. + apply absurd; intros. + pose proof (heΣ _ wfΣ) as [heΣ]. + cbn in *. specialize_Σ wfΣ ; sq. now eapply validity. Qed. diff --git a/safechecker/theories/PCUICWfEnv.v b/safechecker/theories/PCUICWfEnv.v index 8e5f69664..2b9c177c6 100644 --- a/safechecker/theories/PCUICWfEnv.v +++ b/safechecker/theories/PCUICWfEnv.v @@ -42,7 +42,7 @@ Class abstract_env_struct {cf:checker_flags} (abstract_env_impl abstract_env_ext abstract_env_rel : abstract_env_impl -> global_env -> Prop; abstract_env_ext_rel : abstract_env_ext_impl -> global_env_ext -> Prop; - abstract_make_wf_env_ext : forall (X:abstract_env_impl) (univs : universes_decl) + abstract_make_wf_env_ext : forall (X:abstract_env_impl) (univs : universes_decl) (prf : forall Σ : global_env, abstract_env_rel X Σ -> ∥ wf_ext (Σ, univs) ∥), abstract_env_ext_impl ; }. @@ -52,7 +52,7 @@ Definition abstract_env_eq {cf:checker_flags} {abstract_env_impl abstract_env_ex Definition abstract_env_leq {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} (X:abstract_env_ext_impl) := abstract_env_conv_pb_relb X Cumul. -Class abstract_env_prop {cf:checker_flags} (abstract_env_impl abstract_env_ext_impl: Type) +Class abstract_env_prop {cf:checker_flags} (abstract_env_impl abstract_env_ext_impl: Type) `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} : Prop := { abstract_env_ext_exists X : ∥ ∑ Σ , abstract_env_ext_rel X Σ ∥; abstract_env_ext_wf X {Σ} : abstract_env_ext_rel X Σ -> ∥ wf_ext Σ ∥ ; @@ -91,13 +91,13 @@ Class abstract_env_prop {cf:checker_flags} (abstract_env_impl abstract_env_ext_i abstract_env_rel X Σ -> declarations Σ = abstract_env_global_declarations X ; abstract_env_init_correct univs retro cuniv : - abstract_env_rel (abstract_env_init univs retro cuniv) + abstract_env_rel (abstract_env_init univs retro cuniv) {| universes := univs; declarations := []; retroknowledge := retro |} ; abstract_env_add_decl_correct X Σ kn d H : abstract_env_rel X Σ -> abstract_env_rel (abstract_env_add_decl X kn d H) (add_global_decl Σ (kn,d)); abstract_env_add_uctx_rel X {Σ} uctx udecl H H' : (abstract_env_rel X Σ.1 /\ Σ.2 = udecl) <-> - abstract_env_ext_rel (abstract_env_add_uctx X uctx udecl H H') Σ; + abstract_env_ext_rel (abstract_env_add_uctx X uctx udecl H H') Σ; abstract_env_is_consistent_correct uctx udecl : global_uctx_invariants udecl -> gc_of_uctx udecl = Some uctx -> @@ -114,15 +114,15 @@ Class abstract_env_prop {cf:checker_flags} (abstract_env_impl abstract_env_ext_i (Σ:ContextSet.t) = abstract_env_univ X ; abstract_env_retroknowledge_correct X {Σ : global_env} (wfΣ : abstract_env_rel X Σ) : Σ.(retroknowledge) = abstract_env_retroknowledge X ; - abstract_pop_decls_correct X decls (prf : forall Σ : global_env, abstract_env_rel X Σ -> + abstract_pop_decls_correct X decls (prf : forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls) : let X' := abstract_pop_decls X in - forall Σ Σ', abstract_env_rel X Σ -> abstract_env_rel X' Σ' -> - Σ'.(declarations) = decls /\ Σ.(universes) = Σ'.(universes) /\ + forall Σ Σ', abstract_env_rel X Σ -> abstract_env_rel X' Σ' -> + Σ'.(declarations) = decls /\ Σ.(universes) = Σ'.(universes) /\ Σ.(retroknowledge) = Σ'.(retroknowledge); - abstract_make_wf_env_ext_correct X univs prf : + abstract_make_wf_env_ext_correct X univs prf : let X' := abstract_make_wf_env_ext X univs prf in - forall Σ Σ', abstract_env_rel X Σ -> abstract_env_ext_rel X' Σ' -> Σ' = (Σ, univs) + forall Σ Σ', abstract_env_rel X Σ -> abstract_env_ext_rel X' Σ' -> Σ' = (Σ, univs) }. Definition abstract_env_impl {cf:checker_flags} := ∑ X Y Z, @abstract_env_prop _ X Y Z. @@ -148,4 +148,4 @@ Definition abstract_env_ext_sq_wf {cf:checker_flags} (X : abstract_env_impl) (x Qed. Notation "Σ '∼' X" := (abstract_env_rel X Σ) (at level 40). -Notation "Σ '∼_ext' X" := (abstract_env_ext_rel X Σ) (at level 40). +Notation "Σ '∼_ext' X" := (abstract_env_ext_rel X Σ) (at level 40). diff --git a/safechecker/theories/PCUICWfEnvImpl.v b/safechecker/theories/PCUICWfEnvImpl.v index 271b2408a..332bb1c09 100644 --- a/safechecker/theories/PCUICWfEnvImpl.v +++ b/safechecker/theories/PCUICWfEnvImpl.v @@ -3,7 +3,7 @@ From Coq Require Import ssreflect ssrbool. From MetaCoq.Template Require Import config utils uGraph EnvMap. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICEquality PCUICReduction PCUICReflect PCUICSafeLemmata PCUICTyping PCUICGlobalEnv PCUICWfUniverses. -From MetaCoq.SafeChecker Require Import PCUICEqualityDec PCUICWfEnv. +From MetaCoq.SafeChecker Require Import PCUICEqualityDec PCUICWfEnv. From Equations Require Import Equations. Lemma wf_gc_of_uctx {cf:checker_flags} {Σ : global_env} (HΣ : ∥ wf Σ ∥) @@ -65,14 +65,14 @@ Proof. - apply consistent_extension_on_empty. Qed. -Class abstract_guard_impl := +Class abstract_guard_impl := { guard_impl : FixCoFix -> global_env_ext -> context -> mfixpoint term -> bool ; guard_correct : forall fix_cofix Σ Γ mfix, guard fix_cofix Σ Γ mfix <-> guard_impl fix_cofix Σ Γ mfix }. Definition fake_guard_impl : FixCoFix -> global_env_ext -> context -> mfixpoint term -> bool := fun fix_cofix Σ Γ mfix => true. - + Record referenced_impl_ext {cf:checker_flags} {guard : abstract_guard_impl} := { referenced_impl_env_ext :> global_env_ext; referenced_impl_ext_wf :> ∥ wf_ext referenced_impl_env_ext ∥; @@ -91,37 +91,37 @@ Definition init_env : global_env := {| universes := (LS.singleton Level.lzero , CS.empty); declarations := []; retroknowledge := Retroknowledge.empty |}. Definition on_global_univ_init_env : on_global_univs init_env. - repeat split. + repeat split. - intros x Hx; cbn in *. inversion Hx. - intros x Hx; cbn in *. destruct x; eauto. now inversion Hx. - - red. unshelve eexists. + - red. unshelve eexists. + econstructor; eauto. intros; exact 1%positive. + red. intros ? ?. cbn in *. inversion H. -Qed. +Qed. Definition check_conv_pb_relb_correct {cf:checker_flags} (Σ : global_env_ext) (HΣ : ∥ wf_ext Σ ∥) G (HG : is_graph_of_uctx G (global_ext_uctx Σ)) conv_pb u u' : - wf_universe Σ u' -> wf_universe Σ u -> + wf_universe Σ u' -> wf_universe Σ u -> compare_universe conv_pb Σ u u' <-> conv_pb_relb G conv_pb u u'. -Proof. - intros. sq. destruct conv_pb; split; cbn; intro. +Proof. + intros. sq. destruct conv_pb; split; cbn; intro. - apply (check_eqb_universe_complete _ (global_ext_levels Σ, global_ext_constraints Σ)); eauto. + eapply wf_ext_global_uctx_invariants; eauto. - + eapply wf_ext_consistent; eauto. - - apply (check_eqb_universe_spec' G (global_ext_levels Σ, global_ext_constraints Σ)); eauto. + + eapply wf_ext_consistent; eauto. + - apply (check_eqb_universe_spec' G (global_ext_levels Σ, global_ext_constraints Σ)); eauto. + eapply wf_ext_global_uctx_invariants; eauto. - + eapply wf_ext_consistent; eauto. + + eapply wf_ext_consistent; eauto. - apply (check_leqb_universe_complete _ (global_ext_levels Σ, global_ext_constraints Σ)); eauto. + eapply wf_ext_global_uctx_invariants; eauto. - + eapply wf_ext_consistent; eauto. - - apply (check_leqb_universe_spec' G (global_ext_levels Σ, global_ext_constraints Σ)); eauto. + + eapply wf_ext_consistent; eauto. + - apply (check_leqb_universe_spec' G (global_ext_levels Σ, global_ext_constraints Σ)); eauto. + eapply wf_ext_global_uctx_invariants; eauto. - + eapply wf_ext_consistent; eauto. -Qed. + + eapply wf_ext_consistent; eauto. +Qed. Program Definition referenced_pop {cf:checker_flags} (Σ : referenced_impl) : referenced_impl := -match Σ.(declarations) with +match Σ.(declarations) with [] => Σ | (d::decls) => {| referenced_impl_env := {| universes := Σ.(universes); declarations := decls; retroknowledge := Σ.(retroknowledge) |} |} @@ -133,7 +133,7 @@ now depelim ond. Qed. Program Definition make_wf_env_ext {cf:checker_flags} {guard : abstract_guard_impl} -(Σ : referenced_impl) (univs : universes_decl) +(Σ : referenced_impl) (univs : universes_decl) (prf : forall Σ0 : global_env, Σ0 = Σ -> ∥ wf_ext (Σ0, univs) ∥) : referenced_impl_ext := {| referenced_impl_env_ext := (Σ, univs);|}. @@ -157,7 +157,7 @@ Program Global Instance canonical_abstract_env_struct {cf:checker_flags} {guard abstract_env_init := fun cs retro H => {| referenced_impl_env := {| universes := cs ; declarations := []; retroknowledge := retro |}; |} ; - abstract_env_add_decl := fun X kn d H => + abstract_env_add_decl := fun X kn d H => {| referenced_impl_env := add_global_decl X.(referenced_impl_env) (kn,d); |}; abstract_env_empty_ext X := {| referenced_impl_env_ext := (X , Monomorphic_ctx); @@ -217,7 +217,7 @@ Qed. Lemma wf_env_fresh {cf : checker_flags} (Σ : wf_env) : EnvMap.EnvMap.fresh_globals Σ.(declarations). Proof. destruct Σ.(referenced_impl_wf). - now eapply wf_fresh_globals. + now eapply wf_fresh_globals. Qed. Lemma of_global_env_cons {cf:checker_flags} d g : EnvMap.fresh_globals (add_global_decl g d).(declarations) -> @@ -228,23 +228,23 @@ Proof. Qed. Program Definition wf_env_empty {cf:checker_flags} {guard : abstract_guard_impl} := - {| + {| wf_env_referenced := abstract_env_empty ; wf_env_map := EnvMap.empty; |}. - -Program Definition wf_env_init {cf:checker_flags} {guard : abstract_guard_impl} cs retro : + +Program Definition wf_env_init {cf:checker_flags} {guard : abstract_guard_impl} cs retro : on_global_univs cs -> wf_env := fun H => - {| + {| wf_env_referenced := abstract_env_init cs retro H; wf_env_map := EnvMap.empty; |}. -Lemma reference_pop_decls_correct {cf:checker_flags} (X:referenced_impl) decls - (prf : forall Σ : global_env, Σ = X -> +Lemma reference_pop_decls_correct {cf:checker_flags} (X:referenced_impl) decls + (prf : forall Σ : global_env, Σ = X -> exists d, Σ.(declarations) = d :: decls) : let X' := referenced_pop X in - forall Σ Σ', Σ = X -> Σ' = X' -> + forall Σ Σ', Σ = X -> Σ' = X' -> Σ'.(declarations) = decls /\ Σ.(universes) = Σ'.(universes) /\ Σ.(retroknowledge) = Σ'.(retroknowledge). Proof. @@ -254,16 +254,16 @@ Proof. Qed. Program Definition optim_pop {cf:checker_flags} (Σ : wf_env) : wf_env := - match Σ.(referenced_impl_env).(declarations) with + match Σ.(referenced_impl_env).(declarations) with [] => Σ | ((kn , d) :: decls) => {| wf_env_referenced := referenced_pop Σ ; - wf_env_map := EnvMap.EnvMap.remove kn Σ.(wf_env_map); - |} + wf_env_map := EnvMap.EnvMap.remove kn Σ.(wf_env_map); + |} end. Next Obligation. - pose proof Σ.(wf_env_map_repr). red in H. + pose proof Σ.(wf_env_map_repr). red in H. rewrite <- Heq_anonymous in H. set (Σ0 := EnvMap.of_global_env decls). pose proof (EnvMap.remove_add_eq decls kn d Σ0). @@ -274,8 +274,8 @@ Next Obligation. PCUICSR.forward_keep H0. { red. unfold EnvMap.equal. reflexivity. } unfold EnvMap.repr. - rewrite H /=. unfold KernameMapFact.uncurry; cbn. - unfold EnvMap.add in H0. + rewrite H /=. unfold KernameMapFact.uncurry; cbn. + unfold EnvMap.add in H0. unfold referenced_pop. cbn. set (referenced_pop_obligation_1 cf _). clearbody s. destruct (declarations Σ); cbn in *; inversion Heq_anonymous; clear Heq_anonymous s. @@ -284,12 +284,12 @@ Next Obligation. specialize (H0 y). cbn in H0. rewrite H0. reflexivity. Qed. -Program Definition optim_make_wf_env_ext {cf:checker_flags} {guard : abstract_guard_impl} (Σ : wf_env) (univs : universes_decl) +Program Definition optim_make_wf_env_ext {cf:checker_flags} {guard : abstract_guard_impl} (Σ : wf_env) (univs : universes_decl) (prf : forall Σ0 : global_env, abstract_env_rel Σ.(wf_env_referenced) Σ0 -> ∥ wf_ext (Σ0, univs) ∥) : wf_env_ext := {| wf_env_ext_referenced := {| referenced_impl_env_ext := (Σ, univs);|} ; wf_env_ext_map := Σ.(wf_env_map); wf_env_ext_map_repr := Σ.(wf_env_map_repr) |}. - + Program Global Instance optimized_abstract_env_struct {cf:checker_flags} {guard : abstract_guard_impl} : abstract_env_struct wf_env wf_env_ext := {| @@ -302,19 +302,19 @@ Program Global Instance optimized_abstract_env_struct {cf:checker_flags} {guard abstract_env_check_constraints X := abstract_env_check_constraints X.(wf_env_ext_referenced); abstract_env_guard := fun Σ fix_cofix => guard_impl fix_cofix (wf_env_ext_referenced Σ); abstract_env_ext_rel X := abstract_env_ext_rel X.(wf_env_ext_referenced); - + abstract_env_empty := wf_env_empty; abstract_env_init := wf_env_init; abstract_env_add_decl X kn d H := {| wf_env_referenced := @abstract_env_add_decl _ _ referenced_impl_ext _ X.(wf_env_referenced) kn d H ; wf_env_map := EnvMap.add kn d X.(wf_env_map) |}; - abstract_env_empty_ext X := + abstract_env_empty_ext X := {| wf_env_ext_referenced := @abstract_env_empty_ext _ _ referenced_impl_ext _ X.(wf_env_referenced) ; wf_env_ext_map := X.(wf_env_map) |}; abstract_env_global_declarations X := abstract_env_global_declarations X.(wf_env_referenced); abstract_env_is_consistent univ := abstract_env_is_consistent univ; abstract_env_is_consistent_uctx X uctx := abstract_env_is_consistent_uctx X.(wf_env_referenced) uctx; - abstract_env_add_uctx X uctx udecl Huctx Hdecl := + abstract_env_add_uctx X uctx udecl Huctx Hdecl := {| wf_env_ext_referenced := @abstract_env_add_uctx _ _ referenced_impl_ext _ X.(wf_env_referenced) uctx udecl Huctx Hdecl ; wf_env_ext_map := X.(wf_env_map) |}; abstract_env_rel X := abstract_env_rel X.(wf_env_referenced) ; @@ -323,10 +323,10 @@ Program Global Instance optimized_abstract_env_struct {cf:checker_flags} {guard |}. Next Obligation. pose proof (X.(wf_env_referenced).(referenced_impl_wf)) as [?]. - sq. destruct H. - apply EnvMap.repr_add; eauto; try eapply wf_fresh_globals; eauto. + sq. destruct H. + apply EnvMap.repr_add; eauto; try eapply wf_fresh_globals; eauto. apply wf_env_map_repr. -Qed. +Qed. Next Obligation. apply wf_env_map_repr. Qed. Next Obligation. apply wf_env_map_repr. Qed. @@ -358,14 +358,14 @@ Global Hint Variables Opaque : wf_env. Global Hint Resolve referenced_impl_ext_wf : wf_env. Global Hint Resolve referenced_impl_wf : wf_env. -Definition Σudecl_ref {cf : checker_flags} {guard : abstract_guard_impl} (Σ : referenced_impl_ext) : +Definition Σudecl_ref {cf : checker_flags} {guard : abstract_guard_impl} (Σ : referenced_impl_ext) : ∥ on_udecl Σ.(referenced_impl_env_ext).1 Σ.(referenced_impl_env_ext).2 ∥ := map_squash (fun x => x.2) Σ. -Definition Σudecl {cf : checker_flags} {guard : abstract_guard_impl} (Σ : wf_env_ext) : +Definition Σudecl {cf : checker_flags} {guard : abstract_guard_impl} (Σ : wf_env_ext) : ∥ on_udecl Σ.(referenced_impl_env_ext).1 Σ.(referenced_impl_env_ext).2 ∥ := map_squash (fun x => x.2) Σ. - + Global Hint Resolve Σudecl : wf_env. Ltac wf_env := auto with wf_env. @@ -376,7 +376,7 @@ Ltac wf_env := auto with wf_env. convertible to [Σ]. *) Definition build_wf_env_ext {cf : checker_flags} {guard : abstract_guard_impl} (Σ : global_env_ext) (wfΣ : ∥ wf_ext Σ ∥) : wf_env_ext := - {| wf_env_ext_referenced := + {| wf_env_ext_referenced := {| referenced_impl_env_ext := Σ; referenced_impl_ext_wf := wfΣ |} ; wf_env_ext_map := EnvMap.of_global_env Σ.(declarations); wf_env_ext_map_repr := EnvMap.repr_global_env Σ.(declarations); @@ -400,13 +400,13 @@ Section GraphSpec. refine (check_constraints_spec G (global_ext_uctx Σ) _ _ HG _ HH). sq; now eapply wf_ext_global_uctx_invariants. sq; now eapply global_ext_uctx_consistent. - Qed. + Qed. Lemma check_constraints_complete ctrs (H : check_univs) : uctx_invariants ((global_ext_uctx Σ).1, ctrs) -> valid_constraints (global_ext_constraints Σ) ctrs -> check_constraints G ctrs. Proof. pose proof HΣ'. - intros Huctx HH. + intros Huctx HH. refine (check_constraints_complete G (global_ext_uctx Σ) _ _ HG _ _ _ HH); eauto; sq. now eapply wf_ext_global_uctx_invariants. now eapply global_ext_uctx_consistent. @@ -434,27 +434,27 @@ Program Global Instance canonical_abstract_env_prop {cf:checker_flags} {guard : @abstract_env_prop _ _ _ canonical_abstract_env_struct := {| abstract_env_ext_exists := fun Σ => sq (referenced_impl_env_ext Σ ; eq_refl); |}. Next Obligation. wf_env. Qed. -Next Obligation. apply check_conv_pb_relb_correct; eauto; wf_env. +Next Obligation. apply check_conv_pb_relb_correct; eauto; wf_env. apply (graph_of_wf_ext X).π2. Qed. Next Obligation. eapply reflect_iff. eapply reflect_R_global_instance; eauto. move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. - apply iff_reflect; apply check_conv_pb_relb_correct with (conv_pb := Conv); eauto; wf_env. + apply iff_reflect; apply check_conv_pb_relb_correct with (conv_pb := Conv); eauto; wf_env. apply (graph_of_wf_ext X).π2. move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. - apply X0; eauto. + apply X0; eauto. all: rewrite wf_universeb_instance_forall. - revert H; move => / wf_universe_instanceP ?; eauto. - revert H0; move => / wf_universe_instanceP ?; eauto. -Qed. -Next Obligation. split; intros. + revert H; move => / wf_universe_instanceP ?; eauto. + revert H0; move => / wf_universe_instanceP ?; eauto. +Qed. +Next Obligation. split; intros. - eapply check_constraints_complete; eauto. apply referenced_impl_sq_wf. apply Σudecl_ref. apply (graph_of_wf_ext X).π2. - now destruct X. - - eapply check_constraints_spec; eauto. + now destruct X. + - eapply check_constraints_spec; eauto. apply referenced_impl_sq_wf. apply Σudecl_ref. apply (graph_of_wf_ext X).π2. - Qed. + Qed. Next Obligation. apply guard_correct. Qed. Next Obligation. now sq. Qed. Next Obligation. wf_env. Qed. @@ -477,17 +477,17 @@ Next Obligation. apply: consistent_ext_on_full_ext=> //. apply: add_uctx_subgraph. Qed. -Next Obligation. +Next Obligation. apply (reference_pop_decls_correct X decls prf X (referenced_pop X) eq_refl eq_refl). -Qed. +Qed. Program Global Instance optimized_abstract_env_prop {cf:checker_flags} {guard : abstract_guard_impl} : @abstract_env_prop _ _ _ optimized_abstract_env_struct := {| abstract_env_ext_exists := fun Σ => sq (referenced_impl_env_ext Σ ; eq_refl); |}. Next Obligation. wf_env. Qed. - Next Obligation. pose (referenced_impl_ext_wf X). sq. - erewrite EnvMap.lookup_spec; try reflexivity. + Next Obligation. pose (referenced_impl_ext_wf X). sq. + erewrite EnvMap.lookup_spec; try reflexivity. 1: apply wf_fresh_globals; eauto. 1: apply wf_env_ext_map_repr. Qed. Next Obligation. now rewrite (abstract_env_compare_universe_correct X.(wf_env_ext_referenced)). Qed. @@ -501,7 +501,7 @@ Next Obligation. now split. Qed. Next Obligation. now erewrite (@abstract_env_is_consistent_correct _ _ _ _ canonical_abstract_env_prop); eauto. Qed. Next Obligation. now erewrite (abstract_env_is_consistent_uctx_correct X.(wf_env_referenced)); eauto. Qed. Next Obligation. unfold optim_pop. set (optim_pop_obligation_1 cf X). clearbody r. - pose proof (reference_pop_decls_correct X decls prf X (referenced_pop X) eq_refl eq_refl). + pose proof (reference_pop_decls_correct X decls prf X (referenced_pop X) eq_refl eq_refl). specialize (prf _ eq_refl). destruct (declarations X); cbn; inversion prf; inversion H0. subst. now destruct x. @@ -509,12 +509,12 @@ Qed. Definition canonical_abstract_env_impl {cf:checker_flags} {guard : abstract_guard_impl} : abstract_env_impl := (referenced_impl ; referenced_impl_ext ; canonical_abstract_env_struct ; canonical_abstract_env_prop). - + Definition optimized_abstract_env_impl {cf:checker_flags} {guard : abstract_guard_impl} : abstract_env_impl := (wf_env; wf_env_ext ; optimized_abstract_env_struct ; optimized_abstract_env_prop). -Definition build_wf_env_from_env {cf : checker_flags} (Σ : global_env) (wfΣ : ∥ PCUICTyping.wf Σ ∥) : wf_env - := +Definition build_wf_env_from_env {cf : checker_flags} (Σ : global_env) (wfΣ : ∥ PCUICTyping.wf Σ ∥) : wf_env + := let Σm := EnvMap.of_global_env Σ.(declarations) in {| wf_env_referenced := {| referenced_impl_env := Σ; referenced_impl_wf := wfΣ |} ; wf_env_map := Σm; diff --git a/safechecker/theories/PCUICWfReduction.v b/safechecker/theories/PCUICWfReduction.v index 7fdfbf3cc..b77453bbb 100644 --- a/safechecker/theories/PCUICWfReduction.v +++ b/safechecker/theories/PCUICWfReduction.v @@ -54,7 +54,7 @@ Inductive term_direct_subterm : term -> term -> Type := Derive Signature for term_direct_subterm. Definition term_direct_subterm_context (t u : term) (p : term_direct_subterm t u) : context := - match p with + match p with | term_direct_subterm_4_1 na A B => [vass na A] | term_direct_subterm_5_1 na A t => [vass na A] | term_direct_subterm_6_1 na b B t => [vdef na b B] @@ -66,9 +66,9 @@ Require Equations.Type.WellFounded. Definition term_subterm := Relation.trans_clos term_direct_subterm. Fixpoint term_subterm_context {t u : term} (p : term_subterm t u) : context := - match p with + match p with | Relation.t_step y xy => term_direct_subterm_context _ _ xy - | Relation.t_trans y z rxy ryz => + | Relation.t_trans y z rxy ryz => term_subterm_context rxy ++ term_subterm_context ryz end. @@ -88,7 +88,7 @@ Proof. econstructor 2; eauto. Qed. #[global] Instance redp_red Σ Γ : CRelationClasses.subrelation (redp Σ Γ) (red Σ Γ). -Proof. +Proof. intros x y. induction 1; solve [econstructor; eauto]. Qed. @@ -112,7 +112,7 @@ Proof. + now transitivity y. Qed. -(** Well-founded relation allowing to define functions using weak-head reduction +(** Well-founded relation allowing to define functions using weak-head reduction on (welltyped) terms and going under binders. *) Section fix_sigma. Context {cf : checker_flags} {no : normalizing_flags}. @@ -156,7 +156,7 @@ Section fix_sigma. specialize (IHr2 t' ts'). forward IHr2. now rewrite Hts. destruct IHr2 as [t'' [[zt' [ts'' Hts'']]]]. - exists t''. split; split; auto. + exists t''. split; split; auto. now transitivity t'. exists ts''. now rewrite Hts'' Hts. @@ -180,7 +180,7 @@ Section fix_sigma. intros (Γ' & t2 & ?) [(t' & r & ts & eqctx)]. eapply Relation_Properties.clos_rt_rtn1 in r. inversion r. + subst. eapply IH_sub; auto. - intros. + intros. inversion H0. * subst. destruct (term_subterm_red1 X0) as [t'' [[redt' [tst' Htst']]]]. @@ -240,31 +240,31 @@ Section fix_sigma. (* Reducing at least one step or taking a subterm is well-founded *) Definition redp_subterm_rel : Relation_Definitions.relation (∑ Γ t, forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ t) := - fun '(Γ2; t2; H) '(Γ1; t1; H2) => forall Σ (wfΣ : abstract_env_ext_rel X Σ), + fun '(Γ2; t2; H) '(Γ1; t1; H2) => forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ (redp Σ Γ1 t1 t2 * (Γ1 = Γ2)) + ∑ ts : term_subterm t2 t1, Γ2 = (Γ1 ,,, term_subterm_context ts) ∥. Definition wf_redp_subterm_rel : WellFounded redp_subterm_rel. Proof. intros (Γ & s & H). pose proof (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose (wf_extΣ := abstract_env_ext_wf _ wfΣ). sq. + pose (wf_extΣ := abstract_env_ext_wf _ wfΣ). sq. induction (normalisation Σ wf_extΣ Γ s (H _ wfΣ)) as [s _ IH]. induction (term_subterm_wf s) as [s _ IH_sub] in Γ, H, IH |- *. econstructor. intros (Γ' & t2 & ?). intro R. specialize (R _ wfΣ). destruct R as [[[r eq]|[ts eqctx]]]. + subst. eapply Relation_Properties.trans_clos_tn1 in r. - eapply IH. clear -r. + eapply IH. clear -r. induction r; try solve [econstructor; auto]. now eapply cored_trans with y. + subst. apply IH_sub. eauto. intros. eapply cored_redp in H0 as []. destruct (term_subterm_redp X0) as [t'' [[redt' [tst' Htst']]]]. - eapply IH. eapply cored_redp. sq. eassumption. red. intros. + eapply IH. eapply cored_redp. sq. eassumption. red. intros. sq. right. exists tst'. now rewrite Htst'. - Unshelve. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. + Unshelve. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. eapply redp_red in redt'; eapply red_welltyped; sq; eauto. - Unshelve. eauto. + Unshelve. eauto. Defined. Global Instance wf_redp_subterm : WellFounded redp_subterm_rel. diff --git a/safechecker/theories/SafeTemplateChecker.v b/safechecker/theories/SafeTemplateChecker.v index 039224a03..f8191b000 100644 --- a/safechecker/theories/SafeTemplateChecker.v +++ b/safechecker/theories/SafeTemplateChecker.v @@ -8,21 +8,21 @@ From MetaCoq.SafeChecker Require Import PCUICErrors PCUICSafeChecker PCUICWfEnv Import MCMonadNotation. -Definition trans_program (p : Ast.Env.program) : program := +Definition trans_program (p : Ast.Env.program) : program := let Σ' := trans_global_env p.1 in (Σ', trans Σ' p.2). -Definition EnvCheck_wf_env_ext {cf:checker_flags} {guard : abstract_guard_impl} := EnvCheck wf_env_ext. +Definition EnvCheck_wf_env_ext {cf:checker_flags} {guard : abstract_guard_impl} := EnvCheck wf_env_ext. Local Instance Monad_EnvCheck_wf_env_ext {cf:checker_flags} {guard : abstract_guard_impl} : Monad EnvCheck_wf_env_ext := _. -Program Definition infer_template_program {cf : checker_flags} {nor : normalizing_flags} {guard : abstract_guard_impl} +Program Definition infer_template_program {cf : checker_flags} {nor : normalizing_flags} {guard : abstract_guard_impl} (p : Ast.Env.program) φ : EnvCheck_wf_env_ext (let p' := trans_program p in ∑ A, { X : wf_env_ext | ∥ (p'.1, φ) = X.(wf_env_ext_referenced).(referenced_impl_env_ext) × wf_ext (p'.1, φ) × (p'.1, φ) ;;; [] |- p'.2 : A ∥ }) := pp <- typecheck_program (cf := cf) optimized_abstract_env_impl (trans_program p) φ ;; ret (pp.π1 ; (exist (proj1_sig pp.π2) _)). -Next Obligation. +Next Obligation. sq. destruct H; split; eauto. destruct p0; split; eauto. eapply infering_typing; tea. eapply w. constructor. Qed. diff --git a/template-coq/theories/Ast.v b/template-coq/theories/Ast.v index ed4177f9f..2c83c7827 100644 --- a/template-coq/theories/Ast.v +++ b/template-coq/theories/Ast.v @@ -57,7 +57,7 @@ Global Instance predicate_eq_dec term : Proof. ltac:(Equations.Prop.Tactics.eqdec_proof). Qed. Definition string_of_predicate {term} (f : term -> string) (p : predicate term) := - "(" ^ "(" ^ String.concat "," (map f (pparams p)) ^ ")" + "(" ^ "(" ^ String.concat "," (map f (pparams p)) ^ ")" ^ "," ^ string_of_universe_instance (puinst p) ^ ",(" ^ String.concat "," (map (string_of_name ∘ binder_name) (pcontext p)) ^ ")" ^ "," ^ f (preturn p) ^ ")". @@ -71,12 +71,12 @@ Definition eqb_predicate {term} (eqb_univ_instance : Instance.t -> Instance.t -> eqb_univ_instance p.(puinst) p'.(puinst) && forallb2 eqb_binder_annot p.(pcontext) p'.(pcontext) && eqterm p.(preturn) p'.(preturn). - + Section map_predicate. Context {term term' : Type}. Context (uf : Instance.t -> Instance.t). Context (paramf preturnf : term -> term'). - + Definition map_predicate (p : predicate term) := {| pparams := map paramf p.(pparams); puinst := uf p.(puinst); @@ -189,10 +189,10 @@ Section map_predicate_k. Lemma map_k_puinst k (p : predicate term) : uf (puinst p) = puinst (map_predicate_k k p). Proof using Type. reflexivity. Qed. - - Definition test_predicate_k (instp : Instance.t -> bool) + + Definition test_predicate_k (instp : Instance.t -> bool) (p : nat -> term -> bool) k (pred : predicate term) := - instp pred.(puinst) && forallb (p k) pred.(pparams) && + instp pred.(puinst) && forallb (p k) pred.(pparams) && p (#|pred.(pcontext)| + k) pred.(preturn). End map_predicate_k. @@ -204,7 +204,7 @@ Section Branch. bcontext : list aname; (* Names of binders of the branch, in "context" order. Also used for lifting/substitution for the branch body. *) bbody : term; (* The branch body *) }. - + Derive NoConfusion for branch. Global Instance branch_eq_dec : Classes.EqDec term -> @@ -217,10 +217,10 @@ Section Branch. Definition pretty_string_of_branch (f : term -> string) (b : branch) := String.concat " " (map (string_of_name ∘ binder_name) (bcontext b)) ^ " => " ^ f (bbody b). - + Definition test_branch (bodyf : term -> bool) (b : branch) := bodyf b.(bbody). -End Branch. +End Branch. Arguments branch : clear implicits. Section map_branch. @@ -419,7 +419,7 @@ Inductive term : Type := | tInt (i : PrimInt63.int) | tFloat (f : PrimFloat.float). -(** This can be used to represent holes, that, when unquoted, turn into fresh existential variables. +(** This can be used to represent holes, that, when unquoted, turn into fresh existential variables. The fresh evar will depend on the whole context at this point in the term, despite the empty instance. Denotation will call Coq's Typing.solve_evars to try and fill these holes using typing information. *) @@ -435,7 +435,7 @@ Definition mkApps t us := end. (** Term lifting / weakening *) - + Fixpoint lift n k t : term := match t with | tRel i => tRel (if Nat.leb k i then n + i else i) @@ -605,7 +605,7 @@ Fixpoint closedu (k : nat) (t : term) : bool := | tCoFix mfix idx => forallb (test_def (closedu k) (closedu k)) mfix | _ => true - end. + end. Module TemplateTerm <: Term. @@ -761,15 +761,15 @@ Proof. now rewrite app_length /= Nat.add_1_r IHl mapi_rec_app /= rev_app_distr /= Nat.add_0_r. Qed. -(** Helpers for "compact" case representation, reconstructing predicate and +(** Helpers for "compact" case representation, reconstructing predicate and branch contexts. *) - + Definition ind_predicate_context ind mdecl idecl : context := let ictx := (expand_lets_ctx mdecl.(ind_params) idecl.(ind_indices)) in let indty := mkApps (tInd ind (abstract_instance mdecl.(ind_universes))) (to_extended_list (smash_context [] mdecl.(ind_params) ,,, ictx)) in - let inddecl := - {| decl_name := + let inddecl := + {| decl_name := {| binder_name := nNamed (ind_name idecl); binder_relevance := idecl.(ind_relevance) |}; decl_body := None; decl_type := indty |} @@ -777,7 +777,7 @@ Definition ind_predicate_context ind mdecl idecl : context := Definition inst_case_context params puinst (pctx : context) := subst_context (List.rev params) 0 (subst_instance puinst pctx). - + Definition pre_case_predicate_context_gen ind mdecl idecl params puinst : context := inst_case_context params puinst (ind_predicate_context ind mdecl idecl). @@ -794,7 +794,7 @@ Definition cstr_branch_context ind mdecl cdecl : context := cdecl.(cstr_args)). Definition case_branch_context_gen ind mdecl params puinst bctx cdecl : context := - map2 set_binder_name bctx + map2 set_binder_name bctx (inst_case_context params puinst (cstr_branch_context ind mdecl cdecl)). Definition case_branch_context ind mdecl cdecl p (br : branch term) : context := diff --git a/template-coq/theories/AstUtils.v b/template-coq/theories/AstUtils.v index bb3fba025..30c84a4ee 100644 --- a/template-coq/theories/AstUtils.v +++ b/template-coq/theories/AstUtils.v @@ -12,15 +12,15 @@ Module string_of_term_tree. Infix "^" := append. Definition string_of_predicate {term} (f : term -> t) (p : predicate term) := - "(" ^ "(" ^ concat "," (map f (pparams p)) ^ ")" + "(" ^ "(" ^ concat "," (map f (pparams p)) ^ ")" ^ "," ^ string_of_universe_instance (puinst p) ^ ",(" ^ String.concat "," (map (string_of_name ∘ binder_name) (pcontext p)) ^ ")" ^ "," ^ f (preturn p) ^ ")". - + Definition string_of_branch (f : term -> t) (b : branch term) := "([" ^ String.concat "," (map (string_of_name ∘ binder_name) (bcontext b)) ^ "], " ^ f (bbody b) ^ ")". - + Definition string_of_def {A} (f : A -> t) (def : def A) := "(" ^ string_of_name (binder_name (dname def)) ^ "," ^ string_of_relevance (binder_relevance (dname def)) @@ -70,7 +70,7 @@ Module string_of_term_tree. End string_of_term_tree. Definition string_of_term := Tree.to_string ∘ string_of_term_tree.string_of_term. - + Definition decompose_app (t : term) := match t with | tApp f l => (f, l) @@ -241,7 +241,7 @@ Fixpoint strip_casts t := | tLetIn na b t b' => tLetIn na (strip_casts b) (strip_casts t) (strip_casts b') | tCase ind p c brs => let p' := map_predicate id strip_casts strip_casts p in - let brs' := List.map (map_branch strip_casts) brs in + let brs' := List.map (map_branch strip_casts) brs in tCase ind p' (strip_casts c) brs' | tProj p c => tProj p (strip_casts c) | tFix mfix idx => @@ -253,7 +253,7 @@ Fixpoint strip_casts t := | tRel _ | tVar _ | tSort _ | tConst _ _ | tInd _ _ | tConstruct _ _ _ => t | tInt _ | tFloat _ => t end. - + Fixpoint decompose_prod_assum (Γ : context) (t : term) : context * term := match t with | tProd n A B => decompose_prod_assum (Γ ,, vass n A) B @@ -332,7 +332,7 @@ Definition lookup_minductive Σ mind := Definition lookup_inductive Σ ind := match lookup_minductive Σ (inductive_mind ind) with - | Some mdecl => + | Some mdecl => match nth_error mdecl.(ind_bodies) (inductive_ind ind) with | Some idecl => Some (mdecl, idecl) | None => None @@ -346,7 +346,7 @@ Definition destInd (t : term) := | _ => None end. -Definition forget_types {term} (c : list (BasicAst.context_decl term)) : list aname := +Definition forget_types {term} (c : list (BasicAst.context_decl term)) : list aname := map decl_name c. Import MCMonadNotation. @@ -356,19 +356,19 @@ Definition mkCase_old (Σ : global_env) (ci : case_info) (p : term) (c : term) ( '(pctx, preturn) <- decompose_lam_n_assum [] (S #|oib.(ind_indices)|) p ;; '(puinst, pparams, pctx) <- match pctx with - | {| decl_name := na; decl_type := tind; decl_body := Datatypes.None |} :: indices => + | {| decl_name := na; decl_type := tind; decl_body := Datatypes.None |} :: indices => let (hd, args) := decompose_app tind in match destInd hd with | Datatypes.Some (ind, u) => ret (u, firstn mib.(ind_npars) args, forget_types indices) | Datatypes.None => raise tt end - | _ => raise tt + | _ => raise tt end ;; - let p' := + let p' := {| puinst := puinst; pparams := pparams; pcontext := pctx; preturn := preturn |} in brs' <- - monad_map2 (E:=unit) (ME:=option_monad_exc) (fun cdecl br => + monad_map2 (E:=unit) (ME:=option_monad_exc) (fun cdecl br => '(bctx, bbody) <- decompose_lam_n_assum [] #|cdecl.(cstr_args)| br.2 ;; ret {| bcontext := forget_types bctx; bbody := bbody |}) tt oib.(ind_ctors) brs ;; @@ -385,22 +385,22 @@ Definition default_relevance (u : Universe.t) : relevance := (** Convenience functions for building constructors and inductive declarations *) -(** The [indrel] argument represents the de Bruijn associated to the inductive in the mutual block. - index 0 represents the LAST inductive in the block. +(** The [indrel] argument represents the de Bruijn associated to the inductive in the mutual block. + index 0 represents the LAST inductive in the block. The [params] is the context of parameters of the whole inductive block. The [args] context represents the argument types of the constructor (the last argument - of the constructor is the first item in this list, as contexts are represented as snoc lists). *) + of the constructor is the first item in this list, as contexts are represented as snoc lists). *) Definition make_constructor_body (id : ident) (indrel : nat) (params : context) (args : context) (index_terms : list term) : constructor_body := {| cstr_name := id; cstr_args := args; cstr_indices := index_terms; - cstr_type := it_mkProd_or_LetIn (params ,,, args) + cstr_type := it_mkProd_or_LetIn (params ,,, args) (mkApps (tRel (#|args| + #|params| + indrel)) (to_extended_list_k params #|args| ++ index_terms)); cstr_arity := context_assumptions args |}. - + (** Makes a simple inductive body with no projections, and "standard" universe and elimination rules derived from the universe (i.e. does not handle inductives with singleton elimination, or impredicate set eliminations). *) diff --git a/template-coq/theories/BasicAst.v b/template-coq/theories/BasicAst.v index 7757f1f90..93caf8487 100644 --- a/template-coq/theories/BasicAst.v +++ b/template-coq/theories/BasicAst.v @@ -61,16 +61,16 @@ Inductive cast_kind : Set := | Cast. Derive NoConfusion EqDec for cast_kind. -Record case_info := mk_case_info { - ci_ind : inductive; - ci_npar : nat; +Record case_info := mk_case_info { + ci_ind : inductive; + ci_npar : nat; (* Not implemented yet, as the representation in PCUIC doesn't need this cached information. ci_cstr_nargs : list nat; (* The number of REAL arguments of each constructor (no params, no lets) *) ci_cstr_ndecls : list nat; (* The number of arguments of each constructor (no params but lets included) *) *) ci_relevance : relevance }. Derive NoConfusion EqDec for case_info. -Definition string_of_case_info ci := +Definition string_of_case_info ci := "(" ^ string_of_inductive ci.(ci_ind) ^ "," ^ string_of_nat ci.(ci_npar) ^ "," ^ (* string_of_list string_of_nat ci.(ci_cstr_nargs) ^ "," ^ @@ -233,7 +233,7 @@ Section Contexts. }. Derive NoConfusion for context_decl. End Contexts. - + Arguments context_decl : clear implicits. Definition map_decl {term term'} (f : term -> term') (d : context_decl term) : context_decl term' := @@ -246,7 +246,7 @@ Lemma compose_map_decl {term term' term''} (g : term -> term') (f : term' -> ter Proof. destruct x as [? [?|] ?]; reflexivity. Qed. - + Lemma map_decl_ext {term term'} (f g : term -> term') x : (forall x, f x = g x) -> map_decl f x = map_decl g x. Proof. intros H; destruct x as [? [?|] ?]; rewrite /map_decl /=; f_equal; auto. @@ -293,7 +293,7 @@ Definition test_decl {term} (f : term -> bool) (d : context_decl term) : bool := option_default f d.(decl_body) true && f d.(decl_type). #[global] Instance test_decl_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@test_decl term). -Proof. +Proof. intros f g Hfg [na [b|] ty] ? <- => /=; rewrite /test_decl /=; now rewrite Hfg. Qed. @@ -325,13 +325,13 @@ Qed. Lemma mapi_context_length {term} (f : nat -> term -> term) l : #|mapi_context f l| = #|l|. Proof. - induction l; simpl; auto. + induction l; simpl; auto. Qed. #[global] Hint Rewrite @mapi_context_length : len. Section ContextTest. Context {term : Type} (f : term -> bool). - + Fixpoint test_context (c : list (context_decl term)) : bool := match c with | d :: Γ => test_context Γ && test_decl f d @@ -340,14 +340,14 @@ Section ContextTest. End ContextTest. #[global] Instance test_context_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@test_context term). -Proof. +Proof. intros f g Hfg Γ ? <-. induction Γ as [|[na [b|] ty] Γ]; simpl; auto; f_equal; auto; now rewrite Hfg. Qed. Section ContextTestK. Context {term : Type} (f : nat -> term -> bool) (k : nat). - + Fixpoint test_context_k (c : list (context_decl term)) : bool := match c with | d :: Γ => test_context_k Γ && test_decl (f (#|Γ| + k)) d @@ -356,7 +356,7 @@ Section ContextTestK. End ContextTestK. #[global] Instance test_context_k_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq ==> Logic.eq) (@test_context_k term). -Proof. +Proof. intros f g Hfg k ? <- Γ ? <-. induction Γ as [|[na [b|] ty] Γ]; simpl; auto; f_equal; auto; now rewrite Hfg. Qed. @@ -365,7 +365,7 @@ Section Contexts. Context {term term' term'' : Type}. Notation context term := (list (context_decl term)). - Lemma test_decl_impl (f g : term -> bool) x : (forall x, f x -> g x) -> + Lemma test_decl_impl (f g : term -> bool) x : (forall x, f x -> g x) -> test_decl f x -> test_decl g x. Proof using Type. intros Hf; rewrite /test_decl. @@ -373,7 +373,7 @@ Section Contexts. apply/andb_and; split; eauto. destruct (decl_body x); simpl in *; eauto. Qed. - + Definition onctx_k (P : nat -> term -> Type) k (ctx : context term) := Alli (fun i d => ondecl (P (Nat.pred #|ctx| - i + k)) d) 0 ctx. @@ -434,7 +434,7 @@ Section Contexts. Lemma mapi_context_fold f Γ : mapi_context f Γ = fold_context_k f Γ. Proof using Type. - setoid_replace f with (fun k => f (k - 0)) using relation + setoid_replace f with (fun k => f (k - 0)) using relation (pointwise_relation nat (pointwise_relation term (@Logic.eq term')))%signature at 1. rewrite fold_context_k_alt. unfold mapi. generalize 0. @@ -444,7 +444,7 @@ Section Contexts. apply map_decl_ext => t. lia_f_equal. intros k. now rewrite Nat.sub_0_r. Qed. - + Lemma fold_context_k_tip f d : fold_context_k f [d] = [map_decl (f 0) d]. Proof using Type. reflexivity. Qed. @@ -480,7 +480,7 @@ Section Contexts. mapi_context_In (cons x xs) f := cons (f #|xs| x _) (mapi_context_In xs (fun n x H => f n x _)). Lemma mapi_context_In_spec (f : nat -> term -> term) (ctx : context term) : - mapi_context_In ctx (fun n (x : context_decl term) (_ : In x ctx) => map_decl (f n) x) = + mapi_context_In ctx (fun n (x : context_decl term) (_ : In x ctx) => map_decl (f n) x) = mapi_context f ctx. Proof using Type. remember (fun n (x : context_decl term) (_ : In x ctx) => map_decl (f n) x) as g. @@ -489,24 +489,24 @@ Section Contexts. Equations fold_context_In (ctx : context term) (f : context term -> forall (x : context_decl term), In x ctx -> context_decl term) : context term := fold_context_In nil _ := nil; - fold_context_In (cons x xs) f := + fold_context_In (cons x xs) f := let xs' := fold_context_In xs (fun n x H => f n x _) in cons (f xs' x _) xs'. Equations fold_context (f : context term -> context_decl term -> context_decl term) (ctx : context term) : context term := fold_context f nil := nil; - fold_context f (cons x xs) := + fold_context f (cons x xs) := let xs' := fold_context f xs in cons (f xs' x ) xs'. - + Lemma fold_context_length f Γ : #|fold_context f Γ| = #|Γ|. Proof using Type. now apply_funelim (fold_context f Γ); intros; simpl; auto; f_equal. Qed. - + Lemma fold_context_In_spec (f : context term -> context_decl term -> context_decl term) (ctx : context term) : - fold_context_In ctx (fun n (x : context_decl term) (_ : In x ctx) => f n x) = + fold_context_In ctx (fun n (x : context_decl term) (_ : In x ctx) => f n x) = fold_context f ctx. Proof using Type. remember (fun n (x : context_decl term) (_ : In x ctx) => f n x) as g. @@ -521,12 +521,12 @@ Section Contexts. now rewrite (H f' Hff'). Qed. - (** This function allows to forget type annotations on a binding context. - Useful to relate the "compact" case representation in terms, with + (** This function allows to forget type annotations on a binding context. + Useful to relate the "compact" case representation in terms, with its typing relation, where the context has types *) - Definition forget_types (c : list (BasicAst.context_decl term)) : list aname := + Definition forget_types (c : list (BasicAst.context_decl term)) : list aname := map decl_name c. - + End Contexts. #[global] Hint Rewrite @fold_context_length @fold_context_k_length : len. @@ -540,12 +540,12 @@ Section Contexts. rewrite /mapi. generalize 0. induction x; simpl; auto. intros n. - f_equal; auto. + f_equal; auto. now rewrite map_decl_id. Qed. - Lemma fold_context_k_compose (f : nat -> term' -> term) (g : nat -> term'' -> term') Γ : - fold_context_k f (fold_context_k g Γ) = + Lemma fold_context_k_compose (f : nat -> term' -> term) (g : nat -> term'' -> term') Γ : + fold_context_k f (fold_context_k g Γ) = fold_context_k (fun i => f i ∘ g i) Γ. Proof using Type. rewrite !fold_context_k_alt mapi_mapi. @@ -564,13 +564,13 @@ Section Contexts. intros. now apply hfg. Qed. - #[global] Instance fold_context_k_proper : Proper (pointwise_relation nat (pointwise_relation _ Logic.eq) ==> Logic.eq ==> Logic.eq) + #[global] Instance fold_context_k_proper : Proper (pointwise_relation nat (pointwise_relation _ Logic.eq) ==> Logic.eq ==> Logic.eq) (@fold_context_k term' term). Proof using Type. intros f g Hfg x y <-. now apply fold_context_k_ext. Qed. - Lemma alli_fold_context_k_prop (f : nat -> context_decl term -> bool) (g : nat -> term' -> term) ctx : + Lemma alli_fold_context_k_prop (f : nat -> context_decl term -> bool) (g : nat -> term' -> term) ctx : alli f 0 (fold_context_k g ctx) = alli (fun i x => f i (map_decl (g (Nat.pred #|ctx| - i)) x)) 0 ctx. Proof using Type. @@ -584,26 +584,26 @@ Section Contexts. destruct (decl_body x) => //. Qed. - Lemma map_fold_context_k (f : term' -> term) (g : nat -> term'' -> term') ctx : + Lemma map_fold_context_k (f : term' -> term) (g : nat -> term'' -> term') ctx : map (map_decl f) (fold_context_k g ctx) = fold_context_k (fun i => f ∘ g i) ctx. Proof using Type. - rewrite !fold_context_k_alt map_mapi. + rewrite !fold_context_k_alt map_mapi. apply mapi_ext => i d. now rewrite compose_map_decl. Qed. - + Lemma map_context_mapi_context (f : term' -> term) (g : nat -> term'' -> term') (ctx : list (BasicAst.context_decl term'')) : - map_context f (mapi_context g ctx) = + map_context f (mapi_context g ctx) = mapi_context (fun i => f ∘ g i) ctx. Proof using Type. rewrite !mapi_context_fold. now unfold map_context; rewrite map_fold_context_k. Qed. - + Lemma mapi_context_map (f : nat -> term' -> term) (g : context_decl term'' -> context_decl term') ctx : mapi_context f (map g ctx) = mapi (fun i => map_decl (f (Nat.pred #|ctx| - i)) ∘ g) ctx. Proof using Type. rewrite mapi_context_fold fold_context_k_alt mapi_map. now len. Qed. - + Lemma map_context_map (f : term' -> term) (g : context_decl term'' -> context_decl term') ctx : map_context f (map g ctx) = map (map_decl f ∘ g) ctx. Proof using Type. @@ -616,16 +616,16 @@ Section Contexts. now rewrite /map_context map_map_compose. Qed. - Lemma fold_context_k_map (f : nat -> term' -> term) (g : term'' -> term') Γ : - fold_context_k f (map_context g Γ) = + Lemma fold_context_k_map (f : nat -> term' -> term) (g : term'' -> term') Γ : + fold_context_k f (map_context g Γ) = fold_context_k (fun k => f k ∘ g) Γ. Proof using Type. rewrite !fold_context_k_alt mapi_map. apply mapi_ext => n d //. len. now rewrite compose_map_decl. Qed. - - Lemma fold_context_k_map_comm (f : nat -> term -> term) (g : term -> term) Γ : + + Lemma fold_context_k_map_comm (f : nat -> term -> term) (g : term -> term) Γ : (forall i x, f i (g x) = g (f i x)) -> fold_context_k f (map_context g Γ) = map_context g (fold_context_k f Γ). Proof using Type. @@ -640,7 +640,7 @@ Section Contexts. Qed. Lemma mapi_context_map_context (f : nat -> term' -> term) (g : term'' -> term') ctx : - mapi_context f (map_context g ctx) = + mapi_context f (map_context g ctx) = mapi_context (fun i => f i ∘ g) ctx. Proof using Type. now rewrite !mapi_context_fold fold_context_k_map. @@ -657,30 +657,30 @@ Section Contexts. unfold map_context. now rewrite map_decl_id map_id. Qed. - + Lemma forget_types_length (ctx : list (context_decl term)) : #|forget_types ctx| = #|ctx|. Proof using Type. now rewrite /forget_types map_length. Qed. - Lemma map_decl_name_fold_context_k (f : nat -> term' -> term) ctx : + Lemma map_decl_name_fold_context_k (f : nat -> term' -> term) ctx : map decl_name (fold_context_k f ctx) = map decl_name ctx. Proof using Type. now rewrite fold_context_k_alt map_mapi /= mapi_cst_map. Qed. - Lemma forget_types_fold_context_k (f : nat -> term' -> term) ctx : + Lemma forget_types_fold_context_k (f : nat -> term' -> term) ctx : forget_types (fold_context_k f ctx) = forget_types ctx. Proof using Type. now rewrite /forget_types map_decl_name_fold_context_k. Qed. - Lemma All2_fold_impl_onctx (P : context term -> context term -> context_decl term -> context_decl term -> Type) P' Γ Δ Q : + Lemma All2_fold_impl_onctx (P : context term -> context term -> context_decl term -> context_decl term -> Type) P' Γ Δ Q : onctx Q Γ -> All2_fold P Γ Δ -> - (forall Γ Δ d d', - All2_fold P Γ Δ -> + (forall Γ Δ d d', + All2_fold P Γ Δ -> P Γ Δ d d' -> ondecl Q d -> P' Γ Δ d d') -> @@ -690,9 +690,9 @@ Section Contexts. induction cr; depelim onc; constructor; intuition eauto. Qed. - Lemma All2_fold_mapi (P : context term -> context term -> context_decl term -> context_decl term -> Type) (Γ Δ : context term) f g : + Lemma All2_fold_mapi (P : context term -> context term -> context_decl term -> context_decl term -> Type) (Γ Δ : context term) f g : All2_fold (fun Γ Δ d d' => - P (mapi_context f Γ) (mapi_context g Δ) (map_decl (f #|Γ|) d) (map_decl (g #|Γ|) d')) Γ Δ + P (mapi_context f Γ) (mapi_context g Δ) (map_decl (f #|Γ|) d) (map_decl (g #|Γ|) d')) Γ Δ <~> All2_fold P (mapi_context f Γ) (mapi_context g Δ). Proof using Type. split. @@ -704,7 +704,7 @@ Section Contexts. now rewrite <- H0 in p. Qed. - Lemma All2_fold_map {P : context term -> context term -> context_decl term -> context_decl term -> Type} {Γ Δ : context term} f g : + Lemma All2_fold_map {P : context term -> context term -> context_decl term -> context_decl term -> Type} {Γ Δ : context term} f g : All2_fold (fun Γ Δ d d' => P (map_context f Γ) (map_context g Δ) (map_decl f d) (map_decl g d')) Γ Δ <~> All2_fold P (map_context f Γ) (map_context g Δ). @@ -716,7 +716,7 @@ Section Contexts. depelim H; constructor; auto. Qed. - Lemma All2_fold_cst_map {P : context_decl term -> context_decl term -> Type} {Γ Δ : context term} {f g} : + Lemma All2_fold_cst_map {P : context_decl term -> context_decl term -> Type} {Γ Δ : context term} {f g} : All2_fold (fun _ _ d d' => P (f d) (g d')) Γ Δ <~> All2_fold (fun _ _ => P) (map f Γ) (map g Δ). Proof using Type. @@ -731,13 +731,13 @@ Section Contexts. End Contexts. #[global] Hint Rewrite @map_mapi_context - @map_fold_context_k @mapi_context_map @map_context_map @map_map_context + @map_fold_context_k @mapi_context_map @map_context_map @map_map_context @mapi_context_map_context @map_context_mapi_context : map. #[global] Hint Rewrite @forget_types_length : len. (** Primitive types models (axiom free) *) -(** Model of unsigned integers *) +(** Model of unsigned integers *) Definition uint_size := 63. Definition uint_wB := (2 ^ (Z.of_nat uint_size))%Z. Definition uint63_model := { z : Z | ((0 <=? z) && (z match nth_error brs c with - | Some br => + | Some br => match lookup_constructor_decl Σ (inductive_mind ind) (inductive_ind ind) c with - | Checked (mdecl, cdecl) => - let bctx := case_branch_context ind mdecl cdecl p br in + | Checked (mdecl, cdecl) => + let bctx := case_branch_context ind mdecl cdecl p br in reduce_stack Γ n (iota_red ci.(ci_npar) args bctx br) stack | TypeError e => ret (t, stack) end @@ -285,7 +285,7 @@ Section Reduce. puinst := p.(puinst); pcontext := p.(pcontext); preturn := f Γparams (preturn p) |}. - + Definition rebuild_case_branch_ctx ind i p br := match lookup_constructor_decl Σ (inductive_mind ind) (inductive_ind ind) i with | TypeError _ => [] @@ -914,7 +914,7 @@ Section Checker. if wGraph.is_acyclic G then check_wf_declarations univs retro G decls ;; infer_term Σ G (snd p) - else EnvError (IllFormedDecl "toplevel" + else EnvError (IllFormedDecl "toplevel" (UnsatisfiableConstraints univs.2)) end. diff --git a/template-coq/theories/EnvMap.v b/template-coq/theories/EnvMap.v index d7b39028f..6ba57bd3a 100644 --- a/template-coq/theories/EnvMap.v +++ b/template-coq/theories/EnvMap.v @@ -46,14 +46,14 @@ Module EnvMap. Qed. Definition equal (g g' : t) := KernameMap.Equal g g'. - + Lemma unfold_equal g g' : (forall i, lookup i g = lookup i g') -> equal g g'. Proof using Type. intros heq. intros i. apply heq. Qed. - (* Lemma of_global_env_comm {cf:checker_flags} g d d' : + (* Lemma of_global_env_comm {cf:checker_flags} g d d' : fresh_global d.1 (d' :: g) -> fresh_global d'.1 g -> equal (of_global_env (add_global_decl (add_global_decl g d') d)) (of_global_env (add_global_decl (add_global_decl g d) d')). @@ -69,8 +69,8 @@ Module EnvMap. + rewrite !gso //. Qed. *) - (* Lemma add_comm g d d' : - d.1 <> d'.1 -> + (* Lemma add_comm g d d' : + d.1 <> d'.1 -> equal (add d.1 d.2 (add d'.1 d'.2 g)) (add d'.1 d'.2 (add d.1 d.2 g)). Proof. intros hwf. @@ -89,22 +89,22 @@ Module EnvMap. Inductive fresh_globals : list (kername × A) -> Prop := | fresh_globals_empty : fresh_globals [] - | fresh_globals_cons kn d g : + | fresh_globals_cons kn d g : fresh_globals g -> fresh_global kn g -> - fresh_globals ((kn, d) :: g). + fresh_globals ((kn, d) :: g). Derive Signature for fresh_globals. Lemma fold_left_cons d g acc : - fold_left (fun (genv : t) (decl : kername × A) => add decl.1 decl.2 genv) (d :: g) acc = + fold_left (fun (genv : t) (decl : kername × A) => add decl.1 decl.2 genv) (d :: g) acc = fold_left (fun (genv : t) (decl : kername × A) => add decl.1 decl.2 genv) g (add d.1 d.2 acc). Proof using Type. reflexivity. Qed. - + Definition of_global_env (g : list (kername × A)) : t := KernameMapFact.of_list g. - Definition repr (g : list (kername × A)) (e : t) := + Definition repr (g : list (kername × A)) (e : t) := equal e (of_global_env g). Lemma repr_global_env (g : list (kername × A)) : repr g (of_global_env g). @@ -116,8 +116,8 @@ Module EnvMap. unfold of_global_env. simpl. unfold KernameMapFact.uncurry. reflexivity. Qed. - - Lemma repr_add {cf} {Σ : list (kername × A)} e k g : + + Lemma repr_add {cf} {Σ : list (kername × A)} e k g : fresh_globals Σ -> fresh_global k Σ -> repr Σ e -> @@ -135,7 +135,7 @@ Module EnvMap. Lemma lookup_add_other k k' v g : k <> k' -> lookup k (add k' v g) = lookup k g. Proof using Type. move=> eqk. rewrite gso //. Qed. - Lemma remove_add_eq Σ k v e : + Lemma remove_add_eq Σ k v e : fresh_globals Σ -> fresh_global k Σ -> repr Σ e -> @@ -153,7 +153,7 @@ Module EnvMap. - rewrite KernameMapFact.F.add_neq_o //. Qed. - Lemma remove_add_o k k' v e : + Lemma remove_add_o k k' v e : k <> k' -> equal (remove k' (add k v e)) (add k v (remove k' e)). Proof using Type. @@ -176,7 +176,7 @@ Module EnvMap. | d :: tl => if eq_kername kn d.1 then Some d.2 else lookup_global tl kn end. - Lemma lookup_spec (g : list (kername × A)) (e : t) : + Lemma lookup_spec (g : list (kername × A)) (e : t) : fresh_globals g -> repr g e -> forall k, lookup k e = lookup_global g k. @@ -192,7 +192,7 @@ Module EnvMap. now eapply KernameMapFact.F.empty_in_iff in hin. - cbn -[of_global_env eqb]. destruct (eqb_spec k a.1). - * subst. + * subst. rewrite of_global_env_cons //. intros he. unfold lookup. rewrite he. now rewrite [KernameMap.find _ _]lookup_add. @@ -226,7 +226,7 @@ Context {A : Type}. destruct a, a'. repeat move/bool_cons_pos_inj => [] ?; subst; auto. Qed. - + Lemma pos_of_string_inj s s' : pos_of_string s = pos_of_string s' -> s = s'. Proof. induction s in s' |- *; destruct s' => /= //. @@ -250,12 +250,12 @@ Context {A : Type}. end. Fixpoint posapp (p : positive) (q : positive) := - match p with + match p with | xH => q | xI p => xI (posapp p q) | xO p => xO (posapp p q) end. - + Definition pos_cons (hd : positive) (tl : positive) := posapp (listencoding hd) (posapp (xO (xI xH)) tl). @@ -265,7 +265,7 @@ Context {A : Type}. | x :: l => pos_cons (pos_of_string x) (pos_of_stringlist l) end. - Lemma pos_app_inj p1 p2 q1 q2 : + Lemma pos_app_inj p1 p2 q1 q2 : posapp (listencoding p1) q1 = posapp (listencoding p2) q2 -> p1 = p2 /\ q1 = q2. Proof. induction p1 in p2, q1, q2 |- *; destruct p2; cbn; try congruence. @@ -294,8 +294,8 @@ Context {A : Type}. Proof. induction s; destruct s' => /= //. Qed. (* TODO *) - - Fixpoint pos_of_dirpath_cont (d : dirpath) (cont : positive) : positive := + + Fixpoint pos_of_dirpath_cont (d : dirpath) (cont : positive) : positive := match d with | hd :: tl => pos_of_string_cont hd (pos_of_dirpath_cont tl cont) | [] => cont @@ -316,7 +316,7 @@ Context {A : Type}. Definition pos_of_kername (k : kername) : positive := pos_of_modpath_cont k.1 (pos_of_string k.2). - + Lemma pos_of_kername_inj k k' : pos_of_kername k = pos_of_kername k' -> k = k'. Proof. induction k; destruct k'. @@ -336,11 +336,11 @@ Context {A : Type}. Definition of_global_env (g : global_env) : t := List.fold_left (fun genv decl => add decl.1 decl.2 genv) g empty. - + Definition repr (g : global_env) (e : t) := e = of_global_env g. Arguments PTree.set : simpl never. - Lemma of_global_env_comm {cf:checker_flags} g d d' : + Lemma of_global_env_comm {cf:checker_flags} g d d' : fresh_global d.1 (d' :: g) -> fresh_global d'.1 g -> of_global_env (d :: d' :: g) = of_global_env (d' :: d :: g). Proof. @@ -358,7 +358,7 @@ Context {A : Type}. + rewrite !PTree.gso //. Qed. - Lemma add_comm g d d' : + Lemma add_comm g d d' : d.1 <> d'.1 -> add d.1 d.2 (add d'.1 d'.2 g) = add d'.1 d'.2 (add d.1 d.2 g). Proof. intros hwf. @@ -374,16 +374,16 @@ Context {A : Type}. Inductive fresh_globals : global_env -> Prop := | fresh_globals_empty : fresh_globals [] - | fresh_globals_cons kn d g : + | fresh_globals_cons kn d g : fresh_globals g -> fresh_global kn g -> - fresh_globals ((kn, d) :: g). + fresh_globals ((kn, d) :: g). Derive Signature for fresh_globals. Lemma fold_left_cons d g acc : - fold_left (fun (genv : t) (decl : kername × global_decl) => add decl.1 decl.2 genv) (d :: g) acc = + fold_left (fun (genv : t) (decl : kername × global_decl) => add decl.1 decl.2 genv) (d :: g) acc = fold_left (fun (genv : t) (decl : kername × global_decl) => add decl.1 decl.2 genv) g (add d.1 d.2 acc). Proof. reflexivity. Qed. - + Lemma of_global_env_cons {cf:checker_flags} d g : fresh_globals (d :: g) -> of_global_env (d :: g) = add d.1 d.2 (of_global_env g). Proof. @@ -404,7 +404,7 @@ Context {A : Type}. Lemma lookup_add_other k k' v g : k <> k' -> lookup k (add k' v g) = lookup k g. Proof. move=> eqk. rewrite /lookup /add. rewrite PTree.gso //. - move/pos_of_kername_inj. congruence. + move/pos_of_kername_inj. congruence. Qed. Lemma lookup_env_head d g : lookup_env (d :: g) d.1 = Some d.2. diff --git a/template-coq/theories/Environment.v b/template-coq/theories/Environment.v index 0ebd894c5..13bff96fc 100644 --- a/template-coq/theories/Environment.v +++ b/template-coq/theories/Environment.v @@ -21,13 +21,13 @@ Module Type Term. Parameter Inline closedn : nat -> term -> bool. Parameter Inline noccur_between : nat -> nat -> term -> bool. Parameter Inline subst_instance_constr : UnivSubst term. - + Notation lift0 n := (lift n 0). End Term. Module Retroknowledge. - Record t := mk_retroknowledge { + Record t := mk_retroknowledge { retro_int63 : option kername; retro_float64 : option kername; }. @@ -60,7 +60,7 @@ Module Environment (T : Term). (** ** Declarations *) Notation context_decl := (context_decl term). - + (** Local (de Bruijn) variable binding *) Definition vass x A : context_decl := @@ -81,7 +81,7 @@ Module Environment (T : Term). Definition lift_context n k (Γ : context) : context := fold_context_k (fun k' => lift n (k' + k)) Γ. - + Lemma lift_context_alt n k Γ : lift_context n k Γ = mapi (fun k' d => lift_decl n (Nat.pred #|Γ| - k' + k) d) Γ. @@ -95,16 +95,16 @@ Module Environment (T : Term). Definition subst_context s k (Γ : context) : context := fold_context_k (fun k' => subst s (k' + k)) Γ. - + Definition subst_decl s k (d : context_decl) := map_decl (subst s k) d. - + Lemma subst_context_length s n Γ : #|subst_context s n Γ| = #|Γ|. Proof. now rewrite /subst_context; len. Qed. #[global] Hint Rewrite subst_context_length : len. Lemma subst_context_nil s n : subst_context s n [] = []. Proof. reflexivity. Qed. - + Lemma subst_context_alt s k Γ : subst_context s k Γ = mapi (fun k' d => subst_decl s (Nat.pred #|Γ| - k' + k) d) Γ. @@ -112,18 +112,18 @@ Module Environment (T : Term). unfold subst_context, fold_context_k. rewrite rev_mapi. rewrite List.rev_involutive. apply mapi_ext. intros. f_equal. now rewrite List.rev_length. Qed. - + Lemma subst_context_snoc s k Γ d : subst_context s k (d :: Γ) = subst_context s k Γ ,, subst_decl s (#|Γ| + k) d. Proof. now rewrite /subst_context fold_context_k_snoc0. Qed. - + Definition subst_telescope s k (Γ : context) : context := mapi (fun k' decl => map_decl (subst s (k' + k)) decl) Γ. - + Global Instance subst_instance_decl : UnivSubst context_decl := map_decl ∘ subst_instance. - + Global Instance subst_instance_context : UnivSubst context := map_context ∘ subst_instance. @@ -136,7 +136,7 @@ Module Environment (T : Term). {| decl_name := na; decl_body := decl_body x; decl_type := decl_type x |}. - + Fixpoint context_assumptions (Γ : context) := match Γ with | [] => 0 @@ -150,7 +150,7 @@ Module Environment (T : Term). Fixpoint is_assumption_context (Γ : context) := match Γ with | [] => true - | d :: Γ => + | d :: Γ => match d.(decl_body) with | Some _ => false | None => is_assumption_context Γ @@ -165,7 +165,7 @@ Module Environment (T : Term). | {| decl_body := None |} as d :: Γ' => smash_context (Γ ++ [d]) Γ' | [] => Γ end. - + Lemma smash_context_length Γ Γ' : #|smash_context Γ Γ'| = #|Γ| + context_assumptions Γ'. Proof. induction Γ' as [|[na [body|] ty] tl] in Γ |- *; cbn; eauto. @@ -173,7 +173,7 @@ Module Environment (T : Term). - rewrite IHtl app_length. simpl. lia. Qed. #[global] Hint Rewrite smash_context_length : len. - + (* Smashing a context Γ with Δ depending on it is the same as smashing Γ and substituting all references to Γ in Δ by the expansions of let bindings. *) @@ -182,8 +182,8 @@ Module Environment (T : Term). Proof. revert Δ; induction Γ as [|[na [b|] ty]]; intros Δ; simpl; auto. Qed. - - Fixpoint extended_subst (Γ : context) (n : nat) + + Fixpoint extended_subst (Γ : context) (n : nat) (* Δ, smash_context Γ, n |- extended_subst Γ n : Γ *) := match Γ with | nil => nil @@ -208,13 +208,13 @@ Module Environment (T : Term). now destruct a as [? [?|] ?] => /=; simpl; rewrite IHΓ. Qed. #[global] Hint Rewrite extended_subst_length : len. - - Definition expand_lets_k Γ k t := + + Definition expand_lets_k Γ k t := (subst (extended_subst Γ 0) k (lift (context_assumptions Γ) (k + #|Γ|) t)). Definition expand_lets Γ t := expand_lets_k Γ 0 t. - Definition expand_lets_k_ctx Γ k Δ := + Definition expand_lets_k_ctx Γ k Δ := (subst_context (extended_subst Γ 0) k (lift_context (context_assumptions Γ) (k + #|Γ|) Δ)). Definition expand_lets_ctx Γ Δ := expand_lets_k_ctx Γ 0 Δ. @@ -229,23 +229,23 @@ Module Environment (T : Term). Definition fix_context (m : mfixpoint term) : context := List.rev (mapi (fun i d => vass d.(dname) (lift i 0 d.(dtype))) m). - + (** *** Environments *) Record constructor_body := { cstr_name : ident; - (* The arguments and indices are typeable under the context of + (* The arguments and indices are typeable under the context of arities of the mutual inductive + parameters *) cstr_args : context; cstr_indices : list term; - cstr_type : term; + cstr_type : term; (* Closed type: on well-formed constructors: forall params, cstr_args, I params cstr_indices *) cstr_arity : nat; (* arity, w/o lets, w/o parameters *) }. Record projection_body := { proj_name : ident; - (* The arguments and indices are typeable under the context of + (* The arguments and indices are typeable under the context of arities of the mutual inductive + parameters *) proj_relevance : relevance; proj_type : term; (* Type under context of params and inductive object *) @@ -255,14 +255,14 @@ Module Environment (T : Term). {| cstr_name := c.(cstr_name); cstr_args := fold_context_k (fun x => f (x + npars + arities)) c.(cstr_args); cstr_indices := map (f (npars + arities + #|c.(cstr_args)|)) c.(cstr_indices); - (* Note only after positivity checking we can ensure that the indices do not mention the + (* Note only after positivity checking we can ensure that the indices do not mention the inductive type.. beware of lets! *) cstr_type := f arities c.(cstr_type); cstr_arity := c.(cstr_arity) |}. (* Here npars should be the [context_assumptions] of the parameters context. *) Definition map_projection_body npars f c := - {| proj_name := c.(proj_name); + {| proj_name := c.(proj_name); proj_relevance := c.(proj_relevance); proj_type := f (S npars) c.(proj_type) |}. @@ -275,12 +275,12 @@ Module Environment (T : Term). ind_type : term; (* Closed arity = forall mind_params, ind_indices, tSort ind_sort *) ind_kelim : allowed_eliminations; (* Allowed eliminations *) ind_ctors : list constructor_body; - ind_projs : list projection_body; (* names and types of projections, if any. *) + ind_projs : list projection_body; (* names and types of projections, if any. *) ind_relevance : relevance (* relevance of the inductive definition *) }. Definition map_one_inductive_body npars arities f m := match m with - | Build_one_inductive_body ind_name ind_indices ind_sort + | Build_one_inductive_body ind_name ind_indices ind_sort ind_type ind_kelim ind_ctors ind_projs ind_relevance => Build_one_inductive_body ind_name (fold_context_k (fun x => f (npars + x)) ind_indices) ind_sort @@ -332,21 +332,21 @@ Module Environment (T : Term). Coercion universes : global_env >-> ContextSet.t. - Definition empty_global_env := + Definition empty_global_env := {| universes := ContextSet.empty; declarations := []; retroknowledge := Retroknowledge.empty |}. - Definition add_global_decl Σ decl := + Definition add_global_decl Σ decl := {| universes := Σ.(universes); declarations := decl :: Σ.(declarations); retroknowledge := Σ.(retroknowledge) |}. - + Lemma eta_global_env Σ : Σ = {| universes := Σ.(universes); declarations := Σ.(declarations); retroknowledge := Σ.(retroknowledge) |}. Proof. now destruct Σ. Qed. - - Definition set_declarations Σ decls := + + Definition set_declarations Σ decls := {| universes := Σ.(universes); declarations := decls; retroknowledge := Σ.(retroknowledge) |}. @@ -363,14 +363,14 @@ Module Environment (T : Term). Definition extends (Σ Σ' : global_env) := [× Σ.(universes) ⊂_cs Σ'.(universes), - ∑ Σ'', Σ'.(declarations) = Σ'' ++ Σ.(declarations) & + ∑ Σ'', Σ'.(declarations) = Σ'' ++ Σ.(declarations) & Retroknowledge.extends Σ.(retroknowledge) Σ'.(retroknowledge)]. - + Definition extends_decls (Σ Σ' : global_env) := [× Σ.(universes) = Σ'.(universes), ∑ Σ'', Σ'.(declarations) = Σ'' ++ Σ.(declarations) & Σ.(retroknowledge) = Σ'.(retroknowledge)]. - + Existing Class extends. Existing Class extends_decls. @@ -382,25 +382,25 @@ Module Environment (T : Term). #[global] Instance extends_decls_refl : CRelationClasses.Reflexive extends_decls. Proof. red. intros x. split => //; try exists [] => //. Qed. - + Lemma extends_refl : CRelationClasses.Reflexive extends. Proof. red. intros x. split; [apply incl_cs_refl | now exists [] | apply Retroknowledge.extends_refl]. Qed. (* easy prefers this to the local hypotheses, which is annoying #[global] Instance extends_refl : CRelationClasses.Reflexive extends. Proof. apply extends_refl. Qed. - *) + *) Definition primitive_constant (Σ : global_env) (p : prim_tag) : option kername := match p with | primInt => Σ.(retroknowledge).(Retroknowledge.retro_int63) | primFloat => Σ.(retroknowledge).(Retroknowledge.retro_float64) end. - + Definition primitive_invariants (cdecl : constant_body) := ∑ s, [/\ cdecl.(cst_type) = tSort s, cdecl.(cst_body) = None & cdecl.(cst_universes) = Monomorphic_ctx]. - + (** A context of global declarations + global universe constraints, i.e. a global environment *) @@ -451,7 +451,7 @@ Module Environment (T : Term). Lemma it_mkProd_or_LetIn_app l l' t : it_mkProd_or_LetIn (l ++ l') t = it_mkProd_or_LetIn l' (it_mkProd_or_LetIn l t). Proof. induction l in l', t |- *; simpl; auto. Qed. - + Fixpoint reln (l : list term) (p : nat) (Γ0 : list context_decl) {struct Γ0} : list term := match Γ0 with | [] => l @@ -463,7 +463,7 @@ Module Environment (T : Term). Definition to_extended_list Γ := to_extended_list_k Γ 0. Lemma reln_fold f ctx n acc : - reln acc n (fold_context_k f ctx) = + reln acc n (fold_context_k f ctx) = reln acc n ctx. Proof. induction ctx as [|[na [b|] ty] ctx] in n, acc |- *; simpl; auto; @@ -545,7 +545,7 @@ Module Environment (T : Term). Lemma arities_context_length l : #|arities_context l| = #|l|. Proof. unfold arities_context. now rewrite rev_map_length. Qed. #[global] Hint Rewrite arities_context_length : len. - + Lemma app_context_nil_l Γ : [] ,,, Γ = Γ. Proof. unfold app_context. rewrite app_nil_r. reflexivity. @@ -668,43 +668,43 @@ Module Environment (T : Term). induction Γ; simpl; auto. destruct a as [? [?|] ?]; simpl; auto. lia. Qed. - + Lemma context_assumptions_map f Γ : context_assumptions (map_context f Γ) = context_assumptions Γ. Proof. induction Γ as [|[? [?|] ?] ?]; simpl; auto. Qed. - - Lemma context_assumptions_app Γ Δ : context_assumptions (Γ ++ Δ) = + + Lemma context_assumptions_app Γ Δ : context_assumptions (Γ ++ Δ) = context_assumptions Γ + context_assumptions Δ. Proof. induction Γ as [|[? [] ?] ?]; simpl; auto. Qed. - - Lemma context_assumptions_mapi f Γ : context_assumptions (mapi (fun i => map_decl (f i)) Γ) = + + Lemma context_assumptions_mapi f Γ : context_assumptions (mapi (fun i => map_decl (f i)) Γ) = context_assumptions Γ. Proof. rewrite /mapi; generalize 0. induction Γ; simpl; intros; eauto. destruct a as [? [b|] ?]; simpl; auto. Qed. - + #[global] Hint Rewrite context_assumptions_map context_assumptions_mapi context_assumptions_app : len. - Lemma context_assumptions_subst_instance u Γ : - context_assumptions (subst_instance u Γ) = - context_assumptions Γ. + Lemma context_assumptions_subst_instance u Γ : + context_assumptions (subst_instance u Γ) = + context_assumptions Γ. Proof. apply context_assumptions_map. Qed. - Lemma context_assumptions_subst_context s k Γ : - context_assumptions (subst_context s k Γ) = - context_assumptions Γ. + Lemma context_assumptions_subst_context s k Γ : + context_assumptions (subst_context s k Γ) = + context_assumptions Γ. Proof. apply context_assumptions_fold. Qed. - Lemma context_assumptions_lift_context n k Γ : - context_assumptions (lift_context n k Γ) = - context_assumptions Γ. + Lemma context_assumptions_lift_context n k Γ : + context_assumptions (lift_context n k Γ) = + context_assumptions Γ. Proof. apply context_assumptions_fold. Qed. - + #[global] Hint Rewrite context_assumptions_subst_instance context_assumptions_subst_context context_assumptions_lift_context : len. @@ -726,15 +726,15 @@ Module Environment (T : Term). eq_binder_annot na na' -> P t t' -> All_decls_alpha P (vass na t) (vass na' t') - + | on_vdef_alpha na na' b t b' t' : eq_binder_annot na na' -> P b b' -> P t t' -> All_decls_alpha P (vdef na b t) (vdef na' b' t'). Derive Signature NoConfusion for All_decls_alpha. - - Lemma All_decls_impl (P Q : term -> term -> Type) d d' : + + Lemma All_decls_impl (P Q : term -> term -> Type) d d' : All_decls P d d' -> (forall t t', P t t' -> Q t t') -> All_decls Q d d'. @@ -742,7 +742,7 @@ Module Environment (T : Term). intros ond H; destruct ond; constructor; auto. Qed. - Lemma All_decls_alpha_impl (P Q : term -> term -> Type) d d' : + Lemma All_decls_alpha_impl (P Q : term -> term -> Type) d d' : All_decls_alpha P d d' -> (forall t t', P t t' -> Q t t') -> All_decls_alpha Q d d'. @@ -750,14 +750,14 @@ Module Environment (T : Term). intros ond H; destruct ond; constructor; auto. Qed. - Lemma All_decls_to_alpha (P : term -> term -> Type) d d' : + Lemma All_decls_to_alpha (P : term -> term -> Type) d d' : All_decls P d d' -> All_decls_alpha P d d'. Proof. intros []; constructor; auto; reflexivity. Qed. - Definition All2_fold_over (P : context -> context -> context_decl -> context_decl -> Type) Γ Γ' := + Definition All2_fold_over (P : context -> context -> context_decl -> context_decl -> Type) Γ Γ' := All2_fold (All_over P Γ Γ'). Notation on_decls P := (fun Γ Γ' => All_decls (P Γ Γ')). diff --git a/template-coq/theories/EnvironmentTyping.v b/template-coq/theories/EnvironmentTyping.v index 125a75246..66a12b605 100644 --- a/template-coq/theories/EnvironmentTyping.v +++ b/template-coq/theories/EnvironmentTyping.v @@ -28,32 +28,32 @@ Module Lookup (T : Term) (E : EnvironmentSig T). declared_constructor Σ (proj.(proj_ind), 0) mdecl idecl cdecl /\ List.nth_error idecl.(ind_projs) proj.(proj_arg) = Some pdecl /\ mdecl.(ind_npars) = proj.(proj_npars). - - Definition lookup_constant Σ kn := + + Definition lookup_constant Σ kn := match lookup_env Σ kn with | Some (ConstantDecl d) => Some d | _ => None end. - + Definition lookup_minductive Σ mind := match lookup_env Σ mind with | Some (InductiveDecl decl) => Some decl | _ => None end. - + Definition lookup_inductive Σ ind := match lookup_minductive Σ (inductive_mind ind) with - | Some mdecl => + | Some mdecl => match nth_error mdecl.(ind_bodies) (inductive_ind ind) with | Some idecl => Some (mdecl, idecl) | None => None end | None => None end. - + Definition lookup_constructor Σ ind k := match lookup_inductive Σ ind with - | Some (mdecl, idecl) => + | Some (mdecl, idecl) => match nth_error idecl.(ind_ctors) k with | Some cdecl => Some (mdecl, idecl, cdecl) | None => None @@ -63,14 +63,14 @@ Module Lookup (T : Term) (E : EnvironmentSig T). Definition lookup_projection Σ p := match lookup_constructor Σ p.(proj_ind) 0 with - | Some (mdecl, idecl, cdecl) => + | Some (mdecl, idecl, cdecl) => match nth_error idecl.(ind_projs) p.(proj_arg) with | Some pdecl => Some (mdecl, idecl, cdecl, pdecl) | None => None end | _ => None end. - + Lemma declared_constant_lookup {Σ kn cdecl} : declared_constant Σ kn cdecl -> lookup_constant Σ kn = Some cdecl. @@ -79,13 +79,13 @@ Module Lookup (T : Term) (E : EnvironmentSig T). Qed. Lemma lookup_constant_declared {Σ kn cdecl} : - lookup_constant Σ kn = Some cdecl -> + lookup_constant Σ kn = Some cdecl -> declared_constant Σ kn cdecl. Proof. unfold declared_constant, lookup_constant. destruct lookup_env as [[]|] => //. congruence. Qed. - + Lemma declared_minductive_lookup {Σ ind mdecl} : declared_minductive Σ ind mdecl -> lookup_minductive Σ ind = Some mdecl. @@ -93,7 +93,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). rewrite /declared_minductive /lookup_minductive. now intros ->. Qed. - + Lemma lookup_minductive_declared {Σ ind mdecl} : lookup_minductive Σ ind = Some mdecl -> declared_minductive Σ ind mdecl. @@ -101,7 +101,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). rewrite /declared_minductive /lookup_minductive. destruct lookup_env as [[]|] => //. congruence. Qed. - + Lemma declared_inductive_lookup {Σ ind mdecl idecl} : declared_inductive Σ ind mdecl idecl -> lookup_inductive Σ ind = Some (mdecl, idecl). @@ -109,7 +109,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). rewrite /declared_inductive /lookup_inductive. intros []. now rewrite (declared_minductive_lookup H) H0. Qed. - + Lemma lookup_inductive_declared {Σ ind mdecl idecl} : lookup_inductive Σ ind = Some (mdecl, idecl) -> declared_inductive Σ ind mdecl idecl. @@ -122,7 +122,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). Qed. Lemma declared_constructor_lookup {Σ id mdecl idecl cdecl} : - declared_constructor Σ id mdecl idecl cdecl -> + declared_constructor Σ id mdecl idecl cdecl -> lookup_constructor Σ id.1 id.2 = Some (mdecl, idecl, cdecl). Proof. intros []. unfold lookup_constructor. @@ -141,13 +141,13 @@ Module Lookup (T : Term) (E : EnvironmentSig T). Qed. Lemma declared_projection_lookup {Σ p mdecl idecl cdecl pdecl} : - declared_projection Σ p mdecl idecl cdecl pdecl -> + declared_projection Σ p mdecl idecl cdecl pdecl -> lookup_projection Σ p = Some (mdecl, idecl, cdecl, pdecl). Proof. intros [? []]. unfold lookup_projection. rewrite (declared_constructor_lookup (Σ := Σ) H) /= H0 //. Qed. - + Lemma lookup_projection_declared {Σ p mdecl idecl cdecl pdecl} : ind_npars mdecl = p.(proj_npars) -> lookup_projection Σ p = Some (mdecl, idecl, cdecl, pdecl) -> @@ -165,7 +165,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). | ConstantDecl cb => F cb.(cst_universes) | InductiveDecl mb => F mb.(ind_universes) end. - + Definition universes_decl_of_decl := on_udecl_decl (fun x => x). (* Definition LevelSet_add_list l := LevelSet.union (LevelSetProp.of_list l). *) @@ -179,7 +179,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). apply LevelSet.union_spec; right. now apply LevelSet.singleton_spec. Qed. - + Lemma global_levels_memSet univs : LevelSet.mem Level.lzero (global_levels univs) = true. Proof. @@ -237,10 +237,10 @@ Module Lookup (T : Term) (E : EnvironmentSig T). Definition consistent_instance_ext `{checker_flags} Σ := consistent_instance (global_ext_levels Σ) (global_ext_constraints Σ). - + Lemma consistent_instance_length {cf : checker_flags} {Σ : global_env_ext} {univs u} : consistent_instance_ext Σ univs u -> - #|u| = #|abstract_instance univs|. + #|u| = #|abstract_instance univs|. Proof. unfold consistent_instance_ext, consistent_instance. destruct univs; simpl; auto. @@ -253,7 +253,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). Universe.on_sort (fun u => forall l, LevelExprSet.In l u -> LevelSet.In (LevelExpr.get_level l) (global_ext_levels Σ)) True s. - + End Lookup. Module Type LookupSig (T : Term) (E : EnvironmentSig T). @@ -314,12 +314,12 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). Proof. induction 1; intros; simpl; econstructor; eauto. Qed. - + Lemma All_local_env_skipn P Γ : All_local_env P Γ -> forall n, All_local_env P (skipn n Γ). Proof. induction 1; simpl; intros; destruct n; simpl; try econstructor; eauto. Qed. - #[global] + #[global] Hint Resolve All_local_env_skipn : wf. Section All_local_env_rel. @@ -397,10 +397,10 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). | Some b => P Γ b (Typ d.(decl_type)) | None => P Γ d.(decl_type) Sort end. - + Definition on_def_type (P : context -> term -> typ_or_sort -> Type) Γ d := P Γ d.(dtype) Sort. - + Definition on_def_body (P : context -> term -> typ_or_sort -> Type) types Γ d := P (Γ ,,, types) d.(dbody) (Typ (lift0 #|types| d.(dtype))). @@ -413,7 +413,7 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). | Typ T => check Σ Γ t T | Sort => infer_sort Σ Γ t end. - + Lemma lift_judgment_impl {P Ps Q Qs Σ Σ' Γ Γ' t t' T} : lift_judgment P Ps Σ Γ t T -> (forall T, P Σ Γ t T -> Q Σ' Γ' t' T) -> @@ -432,10 +432,10 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). Definition infer_sort (sorting : global_env_ext -> context -> term -> Universe.t -> Type) := (fun Σ Γ T => { s : Universe.t & sorting Σ Γ T s }). Notation typing_sort typing := (fun Σ Γ T s => typing Σ Γ T (tSort s)). - + Definition lift_typing typing := lift_judgment typing (infer_sort (typing_sort typing)). Definition lift_sorting checking sorting := lift_judgment checking (infer_sort sorting). - + Notation Prop_conj P Q := (fun Σ Γ t T => P Σ Γ t T × Q Σ Γ t T). Definition lift_typing2 P Q := lift_typing (Prop_conj P Q). @@ -459,7 +459,7 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). Qed. Lemma lift_typing_impl {P Q Σ Σ' Γ Γ' t t' T} : - lift_typing P Σ Γ t T -> + lift_typing P Σ Γ t T -> (forall T, P Σ Γ t T -> Q Σ' Γ' t' T) -> lift_typing Q Σ' Γ' t' T. Proof. @@ -505,7 +505,7 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). Definition All_local_env_over typing property := (All_local_env_over_gen typing (infer_sort (typing_sort typing)) property (fun Σ Γ H t tu => property _ _ H _ _ tu.π2)). - + Definition All_local_env_over_sorting checking sorting cproperty (sproperty : forall Σ Γ _ t s, sorting Σ Γ t s -> Type) := (All_local_env_over_gen checking (infer_sort sorting) cproperty (fun Σ Γ H t tu => sproperty Σ Γ H t tu.π1 tu.π2)). @@ -515,7 +515,7 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). (* Γ |- s : Δ, where Δ is a telescope (reverse context) *) Inductive ctx_inst Σ (Γ : context) : list term -> context -> Type := | ctx_inst_nil : ctx_inst Σ Γ [] [] - | ctx_inst_ass na t i inst Δ : + | ctx_inst_ass na t i inst Δ : typing Σ Γ i t -> ctx_inst Σ Γ inst (subst_telescope [i] 0 Δ) -> ctx_inst Σ Γ (i :: inst) (vass na t :: Δ) @@ -525,7 +525,7 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). Derive Signature NoConfusion for ctx_inst. End TypeCtxInst. - Lemma ctx_inst_impl P Q Σ Γ inst Δ : + Lemma ctx_inst_impl P Q Σ Γ inst Δ : ctx_inst P Σ Γ inst Δ -> (forall t T, P Σ Γ t T -> Q Σ Γ t T) -> ctx_inst Q Σ Γ inst Δ. @@ -543,7 +543,7 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). | localenv_cons_abs Γ' na t w' p => Psize _ _ _ _ p + All_local_env_size_gen base _ _ w' | localenv_cons_def Γ' na b t w' pt pb => Psize _ _ _ _ pt + Psize _ _ _ _ pb + All_local_env_size_gen base _ _ w' end. - + Lemma All_local_env_size_pos base Σ Γ w : base <= All_local_env_size_gen base Σ Γ w. Proof using Type. induction w. @@ -593,7 +593,7 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). Section Regular. Context {typing : global_env_ext -> context -> term -> term -> Type}. Context (typing_size : forall Σ Γ t T, typing Σ Γ t T -> size). - + Definition lift_typing_size := lift_judgment_size typing_size (infer_sort_size (typing_sort_size typing_size)). Definition All_local_env_size := All_local_env_size_gen lift_typing_size 0. Definition All_local_rel_size := All_local_rel_size_gen lift_typing_size 0. @@ -627,10 +627,10 @@ Module Conversion (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) (ET : E (eqna : eq_binder_annot na na') (eqt : P pb t t') : All_decls_alpha_pb (vass na t) (vass na' t') - + | all_decls_alpha_vdef {na na' : binder_annot name} {b t b' t' : term} (eqna : eq_binder_annot na na') - (eqb : P Conv b b') (* Note that definitions must be convertible, otherwise this notion + (eqb : P Conv b b') (* Note that definitions must be convertible, otherwise this notion of cumulativity is useless *) (eqt : P pb t t') : All_decls_alpha_pb (vdef na b t) (vdef na' b' t'). @@ -638,13 +638,13 @@ Module Conversion (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) (ET : E Derive Signature NoConfusion for All_decls_alpha_pb. Arguments All_decls_alpha_pb pb P : clear implicits. - + Definition cumul_pb_decls pb (Σ : global_env_ext) (Γ Γ' : context) : forall (x y : context_decl), Type := All_decls_alpha_pb pb (cumul_gen Σ Γ). - Definition cumul_pb_context pb (Σ : global_env_ext) := + Definition cumul_pb_context pb (Σ : global_env_ext) := All2_fold (cumul_pb_decls pb Σ). - + Definition cumul_ctx_rel Σ Γ Δ Δ' := All2_fold (fun Δ Δ' => cumul_pb_decls Cumul Σ (Γ ,,, Δ) (Γ ,,, Δ')) Δ Δ'. End Conversion. @@ -690,9 +690,9 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Fixpoint sorts_local_ctx Σ (Γ Δ : context) (us : list Universe.t) : Type := match Δ, us with | [], [] => unit - | {| decl_body := None; decl_type := t |} :: Δ, u :: us => + | {| decl_body := None; decl_type := t |} :: Δ, u :: us => sorts_local_ctx Σ Γ Δ us × P Σ (Γ ,,, Δ) t (Typ (tSort u)) - | {| decl_body := Some b; decl_type := t |} :: Δ, us => + | {| decl_body := Some b; decl_type := t |} :: Δ, us => sorts_local_ctx Σ Γ Δ us × P Σ (Γ ,,, Δ) t Sort × P Σ (Γ ,,, Δ) b (Typ t) | _, _ => False end. @@ -726,7 +726,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT /\ satisfiable_udecl univs udecl /\ valid_on_mono_udecl univs udecl. - (** Positivity checking of the inductive, ensuring that the inductive itself + (** Positivity checking of the inductive, ensuring that the inductive itself can only appear at the right of an arrow in each argument's types. *) (* Definition positive_cstr_arg ninds npars narg (arg : term) : bool := @@ -738,14 +738,14 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT alli (fun i d => noccur_between (npars + narg + i) ninds d.(decl_type)) 0 (List.rev ctx) && let (hd, args) := decompose_app concl in match hd with - | tRel i => - if noccur_between (npars + narg + #|ctx|) ninds (tRel i) then + | tRel i => + if noccur_between (npars + narg + #|ctx|) ninds (tRel i) then (* Call to an unrelated variable *) true else (* Recursive call to the inductive *) (* Coq disallows the inductive to be applied to another inductive in the block *) forallb (noccur_between (npars + narg + #|ctx|) ninds) args - | tInd ind u => + | tInd ind u => if forallb (noccur_between (npars + narg + #|ctx|) ninds) args then (* Unrelated inductive *) true @@ -755,36 +755,36 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Definition positive_cstr_args ninds npars (args : context) : bool := alli (fun i decl => positive_cstr_arg nind npars i decl.(decl_type)) - (* We smash the context, just as Coq's kernel computes positivity on + (* We smash the context, just as Coq's kernel computes positivity on weak-head normalized types *) (List.rev (smash_context [] args)) *) (** A constructor argument type [t] is positive w.r.t. an inductive block [mdecl] - when it's zeta-normal form is of the shape Π Δ. concl and: + when it's zeta-normal form is of the shape Π Δ. concl and: - [t] does not refer to any inductive in the block. In that case [t] must be a closed type under the context of parameters and previous arguments. - - None of the variable assumptions in Δ refer to any inductive in the block, - but the conclusion [concl] is of the form [mkApps (tRel k) args] for k + - None of the variable assumptions in Δ refer to any inductive in the block, + but the conclusion [concl] is of the form [mkApps (tRel k) args] for k refering to an inductive in the block, and none of the arguments [args] - refer to the inductive. #|args| must be the length of the full inductive application. - + refer to the inductive. #|args| must be the length of the full inductive application. + Let-in assumptions in Δ are systematically unfolded, i.e. we really consider: the zeta-reduction of [t]. *) - - Definition ind_realargs (o : one_inductive_body) := + + Definition ind_realargs (o : one_inductive_body) := match destArity [] o.(ind_type) with | Some (ctx, _) => #|smash_context [] ctx| | _ => 0 end. Inductive positive_cstr_arg mdecl ctx : term -> Type := - | positive_cstr_arg_closed t : + | positive_cstr_arg_closed t : closedn #|ctx| t -> positive_cstr_arg mdecl ctx t - | positive_cstr_arg_concl l k i : + | positive_cstr_arg_concl l k i : (** Mutual inductive references in the conclusion are ok *) #|ctx| <= k -> k < #|ctx| + #|mdecl.(ind_bodies)| -> All (closedn #|ctx|) l -> @@ -794,7 +794,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT | positive_cstr_arg_let na b ty t : positive_cstr_arg mdecl ctx (subst [b] 0 t) -> - positive_cstr_arg mdecl ctx (tLetIn na b ty t) + positive_cstr_arg mdecl ctx (tLetIn na b ty t) | positive_cstr_arg_ass na ty t : closedn #|ctx| ty -> @@ -802,23 +802,23 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT positive_cstr_arg mdecl ctx (tProd na ty t). (** A constructor type [t] is positive w.r.t. an inductive block [mdecl] - and inductive [i] when it's zeta normal-form is of the shape Π Δ. concl and: + and inductive [i] when it's zeta normal-form is of the shape Π Δ. concl and: - All of the arguments in Δ are positive. - - The conclusion is of the shape [mkApps (tRel k) indices] + - The conclusion is of the shape [mkApps (tRel k) indices] where [k] refers to the current inductive [i] and [indices] does not mention any of the inductive types in the block. I.e. [indices] are closed terms in [params ,,, args]. *) - + Inductive positive_cstr mdecl i (ctx : context) : term -> Type := | positive_cstr_concl indices : - let headrel : nat := + let headrel : nat := (#|mdecl.(ind_bodies)| - S i + #|ctx|)%nat in All (closedn #|ctx|) indices -> positive_cstr mdecl i ctx (mkApps (tRel headrel) indices) | positive_cstr_let na b ty t : positive_cstr mdecl i ctx (subst [b] 0 t) -> - positive_cstr mdecl i ctx (tLetIn na b ty t) + positive_cstr mdecl i ctx (tLetIn na b ty t) | positive_cstr_ass na ty t : positive_cstr_arg mdecl ctx ty -> @@ -826,7 +826,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT positive_cstr mdecl i ctx (tProd na ty t). Definition lift_level n l := - match l with + match l with | Level.lzero | Level.Level _ => l | Level.Var k => Level.Var (n + k) end. @@ -848,7 +848,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Fixpoint variance_cstrs (v : list Variance.t) (u u' : Instance.t) := match v, u, u' with | _, [], [] => ConstraintSet.empty - | v :: vs, u :: us, u' :: us' => + | v :: vs, u :: us, u' :: us' => match v with | Variance.Irrelevant => variance_cstrs vs us us' | Variance.Covariant => ConstraintSet.add (u, ConstraintType.Le 0, u') (variance_cstrs vs us us') @@ -857,7 +857,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT | _, _, _ => (* Impossible due to on_variance invariant *) ConstraintSet.empty end. - (** This constructs a duplication of the polymorphic universe context of the inductive, + (** This constructs a duplication of the polymorphic universe context of the inductive, where the two instances are additionally related according to the variance information. *) @@ -874,10 +874,10 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Some (Polymorphic_ctx auctx', u, u') end. - (** A constructor type respects the given variance [v] if each constructor + (** A constructor type respects the given variance [v] if each constructor argument respects it and each index (in the conclusion) does as well. We formalize this by asking for a cumulativity relation between the contexts - of arguments and conversion of the lists of indices instanciated with [u] and + of arguments and conversion of the lists of indices instanciated with [u] and [u'] where [u `v` u']. *) Definition ind_arities mdecl := arities_context (ind_bodies mdecl). @@ -899,7 +899,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT cumul_ctx_rel Pcmp (Σ, univs) (ind_arities mdecl ,,, smash_context [] (ind_params mdecl))@[u] (expand_lets_ctx (ind_params mdecl) (smash_context [] (cstr_args cs)))@[u] (expand_lets_ctx (ind_params mdecl) (smash_context [] (cstr_args cs)))@[u'] * - All2 + All2 (Pcmp (Σ, univs) (ind_arities mdecl ,,, smash_context [] (ind_params mdecl ,,, cstr_args cs))@[u] Conv) (map (subst_instance u ∘ expand_lets (ind_params mdecl ,,, cstr_args cs)) (cstr_indices cs)) (map (subst_instance u' ∘ expand_lets (ind_params mdecl ,,, cstr_args cs)) (cstr_indices cs)) @@ -911,20 +911,20 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT tRel (#|mdecl.(ind_bodies)| - S i + #|mdecl.(ind_params)| + #|cstr_args cdecl|). (* Constructor conclusion shape: the inductives type applied to variables for - the (non-let) parameters + the (non-let) parameters followed by the indices *) Definition cstr_concl mdecl i cdecl := (mkApps (cstr_concl_head mdecl i cdecl) (to_extended_list_k mdecl.(ind_params) #|cstr_args cdecl| ++ cstr_indices cdecl)). - + Record on_constructor Σ mdecl i idecl ind_indices cdecl cunivs := { (* cdecl.1 fresh ?? *) cstr_args_length : context_assumptions (cstr_args cdecl) = cstr_arity cdecl; cstr_eq : cstr_type cdecl = - it_mkProd_or_LetIn mdecl.(ind_params) - (it_mkProd_or_LetIn (cstr_args cdecl) + it_mkProd_or_LetIn mdecl.(ind_params) + (it_mkProd_or_LetIn (cstr_args cdecl) (cstr_concl mdecl i cdecl)); (* The type of the constructor canonically has this shape: parameters, real arguments ending with a reference to the inductive applied to the @@ -934,7 +934,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT on_cargs : sorts_local_ctx Σ (arities_context mdecl.(ind_bodies) ,,, mdecl.(ind_params)) cdecl.(cstr_args) cunivs; - on_cindices : + on_cindices : ctx_inst (fun Σ Γ t T => P Σ Γ t (Typ T)) Σ (arities_context mdecl.(ind_bodies) ,,, mdecl.(ind_params) ,,, cdecl.(cstr_args)) cdecl.(cstr_indices) (List.rev (lift_context #|cdecl.(cstr_args)| 0 ind_indices)); @@ -942,13 +942,13 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT on_ctype_positive : (* The constructor type is positive *) positive_cstr mdecl i [] (cstr_type cdecl); - on_ctype_variance : (* The constructor type respect the variance annotation + on_ctype_variance : (* The constructor type respect the variance annotation on polymorphic universes, if any. *) - forall v, ind_variance mdecl = Some v -> + forall v, ind_variance mdecl = Some v -> cstr_respects_variance Σ mdecl v cdecl; - on_lets_in_type : if lets_in_constructor_types - then True else is_true (is_assumption_context (cstr_args cdecl)) + on_lets_in_type : if lets_in_constructor_types + then True else is_true (is_assumption_context (cstr_args cdecl)) }. Arguments on_ctype {Σ mdecl i idecl ind_indices cdecl cunivs}. @@ -960,30 +960,30 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Definition on_constructors Σ mdecl i idecl ind_indices := All2 (on_constructor Σ mdecl i idecl ind_indices). - (** Each projection type corresponds to a non-let argument of the - corresponding constructor. It is parameterized over the + (** Each projection type corresponds to a non-let argument of the + corresponding constructor. It is parameterized over the parameters of the inductive type and all the preceding arguments of the constructor. When computing the type of a projection for argument [n] at a given instance of the parameters and a given term [t] in the inductive type, we instantiate the argument context by corresponsping projections [t.π1 ... t.πn-1]. This is essential for subject reduction to hold: each projections type can only refer to the record object through projections. - + Projection types have their parameter and argument contexts smashed to avoid costly computations during type-checking and reduction: we can just substitute - the instances of parameters and the inductive value without considering the + the instances of parameters and the inductive value without considering the presence of let bindings. *) Record on_proj mdecl mind i k (p : projection_body) decl := { on_proj_name : (* All projections are be named after a constructor argument. *) binder_name (decl_name decl) = nNamed p.(proj_name); - on_proj_type : + on_proj_type : (** The stored projection type already has the references to the inductive type substituted along with the previous arguments replaced by projections. *) let u := abstract_instance mdecl.(ind_universes) in let ind := {| inductive_mind := mind; inductive_ind := i |} in p.(proj_type) = subst (inds mind u mdecl.(ind_bodies)) (S (ind_npars mdecl)) - (subst (projs ind mdecl.(ind_npars) k) 0 + (subst (projs ind mdecl.(ind_npars) k) 0 (lift 1 k (decl_type decl))); on_proj_relevance : p.(proj_relevance) = decl.(decl_name).(binder_relevance) }. @@ -1010,7 +1010,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT on_projs : Alli (on_projection mdecl mind i cdecl) 0 idecl.(ind_projs) }. Definition check_constructors_smaller φ cunivss ind_sort := - Forall (fun cunivs => + Forall (fun cunivs => Forall (fun argsort => leq_universe φ argsort ind_sort) cunivs) cunivss. (** This ensures that all sorts in kelim are lower @@ -1030,7 +1030,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT IntoPropSProp (* Squashed: some arguments are higher than Prop, restrict to Prop *) | _ => (* Squashed: at least 2 constructors *) IntoPropSProp end. - + Definition elim_sort_sprop_ind (ind_ctors_sort : list constructor_univs) := match ind_ctors_sort with | [] => (* Empty inductive strict proposition: *) IntoAny @@ -1056,7 +1056,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT × if indices_matter then type_local_ctx Σ params ind_indices ind_sort else True. - + Record on_ind_body Σ mind mdecl i idecl := { (** The type of the inductive must be an arity, sharing the same params as the rest of the block, and maybe having a context of indices. *) @@ -1090,27 +1090,27 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT check_ind_sorts Σ mdecl.(ind_params) idecl.(ind_kelim) idecl.(ind_indices) ind_cunivs idecl.(ind_sort); - onIndices : + onIndices : (* The inductive type respect the variance annotation on polymorphic universes, if any. *) - forall v, ind_variance mdecl = Some v -> + forall v, ind_variance mdecl = Some v -> ind_respects_variance Σ mdecl v idecl.(ind_indices) }. Definition on_variance Σ univs (variances : option (list Variance.t)) := match univs return Type with | Monomorphic_ctx => variances = None - | Polymorphic_ctx auctx => + | Polymorphic_ctx auctx => match variances with | None => unit - | Some v => - ∑ univs' i i', + | Some v => + ∑ univs' i i', [× (variance_universes univs v = Some (univs', i, i')), consistent_instance_ext (Σ, univs') univs i, consistent_instance_ext (Σ, univs') univs i' & List.length v = #|UContext.instance (AUContext.repr auctx)|] end end. - + (** We allow empty blocks for simplicity (no well-typed reference to them can be made). *) @@ -1166,10 +1166,10 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Derive Signature for on_global_decls. - Definition on_global_univs (c : ContextSet.t) := + Definition on_global_univs (c : ContextSet.t) := let levels := global_levels c in let cstrs := ContextSet.constraints c in - ConstraintSet.For_all (declared_cstr_levels levels) cstrs /\ + ConstraintSet.For_all (declared_cstr_levels levels) cstrs /\ LS.For_all (negb ∘ Level.is_var) levels /\ consistent cstrs. @@ -1226,7 +1226,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Lemma on_global_env_impl {cf : checker_flags} Pcmp P Q : (forall Σ Γ t T, - on_global_env Pcmp P Σ.1 -> + on_global_env Pcmp P Σ.1 -> on_global_env Pcmp Q Σ.1 -> P Σ Γ t T -> Q Σ Γ t T) -> forall Σ, on_global_env Pcmp P Σ -> on_global_env Pcmp Q Σ. @@ -1236,8 +1236,8 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT induction g; intros; auto. constructor; auto. depelim IH. specialize (IHg cu IH). constructor; auto. pose proof (globenv_decl _ _ _ _ _ _ _ IH o). - destruct o. constructor; auto. - assert (X' := fun Γ t T => X ({| universes := univs; declarations := _ |}, udecl0) Γ t T + destruct o. constructor; auto. + assert (X' := fun Γ t T => X ({| universes := univs; declarations := _ |}, udecl0) Γ t T (cu, IH) (cu, IHg)); clear X. rename X' into X. clear IH IHg. destruct d; simpl. @@ -1262,7 +1262,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT revert on_cindices0. generalize (List.rev (lift_context #|cstr_args x0| 0 (ind_indices x))). generalize (cstr_indices x0). - induction 1; simpl; constructor; auto. + induction 1; simpl; constructor; auto. --- simpl; intros. pose (onProjections X1 H). simpl in *; auto. --- destruct X1. simpl. unfold check_ind_sorts in *. destruct Universe.is_prop; auto. @@ -1286,7 +1286,7 @@ End GlobalMapsSig. Module Type ConversionParSig (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) (ET : EnvTypingSig T E TU). Import T E TU ET. - + Parameter Inline cumul_gen : forall {cf : checker_flags}, global_env_ext -> context -> conv_pb -> term -> term -> Type. End ConversionParSig. @@ -1307,7 +1307,7 @@ End Typing. Module DeclarationTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) (ET : EnvTypingSig T E TU) (CT : ConversionSig T E TU ET) - (CS : ConversionParSig T E TU ET) (Ty : Typing T E TU ET CT CS) + (CS : ConversionParSig T E TU ET) (Ty : Typing T E TU ET CT CS) (L : LookupSig T E) (GM : GlobalMapsSig T E TU ET CT L). Import T E L TU ET CT GM CS Ty. @@ -1336,11 +1336,11 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) Definition wf_local_rel `{checker_flags} Σ := All_local_rel (lift_typing typing Σ). - (** Functoriality of global environment typing derivations + folding of the well-formed + (** Functoriality of global environment typing derivations + folding of the well-formed environment assumption. *) Lemma on_wf_global_env_impl `{checker_flags} {Σ : global_env} {wfΣ : on_global_env cumul_gen (lift_typing typing) Σ} P Q : - (forall Σ Γ t T, on_global_env cumul_gen (lift_typing typing) Σ.1 -> - on_global_env cumul_gen P Σ.1 -> + (forall Σ Γ t T, on_global_env cumul_gen (lift_typing typing) Σ.1 -> + on_global_env cumul_gen P Σ.1 -> on_global_env cumul_gen Q Σ.1 -> P Σ Γ t T -> Q Σ Γ t T) -> on_global_env cumul_gen P Σ -> on_global_env cumul_gen Q Σ. @@ -1351,8 +1351,8 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) revert X0. generalize (universes Σ) as univs, (retroknowledge Σ) as retro, (declarations Σ). clear hu Σ. induction 1; constructor; try destruct o; try constructor; auto. { depelim wfΣ. eauto. } - depelim wfΣ. specialize (IHX0 cu wfΣ). destruct o. - assert (X' := fun Γ t T => X ({| universes := univs; declarations := Σ |}, udecl0) Γ t T + depelim wfΣ. specialize (IHX0 cu wfΣ). destruct o. + assert (X' := fun Γ t T => X ({| universes := univs; declarations := Σ |}, udecl0) Γ t T (cu, wfΣ) (cu, X0) (cu, IHX0)); clear X. rename X' into X. clear IHX0. destruct d; simpl. diff --git a/template-coq/theories/EtaExpand.v b/template-coq/theories/EtaExpand.v index 2e6c95f28..ad32fda9d 100644 --- a/template-coq/theories/EtaExpand.v +++ b/template-coq/theories/EtaExpand.v @@ -32,7 +32,7 @@ Import ListNotations. Section Eta. Context (Σ : GlobalEnvMap.t). -(* +(* Fixpoint remove_top_prod (t : Ast.term) (n : nat) := match n,t with | O, _ => t @@ -57,9 +57,9 @@ Section Eta. let prev_args := map (lift0 needed) args in let eta_args := rev_map tRel (seq 0 needed) in let remaining := firstn needed (skipn #|args| (rev (smash_context [] (decompose_prod_assum [] ty).1))) in - let remaining_subst := subst_context (rev args) 0 remaining in + let remaining_subst := subst_context (rev args) 0 remaining in fold_right (fun d b => Ast.tLambda d.(decl_name) d.(decl_type) b) (mkApps (lift0 needed t) (prev_args ++ eta_args)) remaining_subst. - + Definition eta_constructor (ind : inductive) c u args := match GlobalEnvMap.lookup_constructor Σ ind c with | Some (mdecl, idecl, cdecl) => @@ -68,7 +68,7 @@ Section Eta. Some (eta_single (Ast.tConstruct ind c u) args ty n) | _ => None end. - + Definition eta_fixpoint (def : mfixpoint term) (i : nat) d (args : list term) := eta_single (tFix def i) args (d.(dtype)) (1 + d.(rarg)). @@ -84,30 +84,30 @@ Section Eta. | Some (Some (c, ty)) => eta_single (tRel n) [] (lift0 (S n) ty) c | _ => tRel n end - + | tApp hd args => match hd with | tConstruct ind c u => - match eta_constructor ind c u (map (eta_expand Γ) args) with + match eta_constructor ind c u (map (eta_expand Γ) args) with | Some res => res | None => tVar ("Error: lookup of an inductive failed for " ++ string_of_kername ind.(inductive_mind)) end - | tFix def i => - let def' := - map (fun d => + | tFix def i => + let def' := + map (fun d => let ctx := List.rev (mapi (fun (i : nat) d => Some (1 + d.(rarg), (lift0 i (dtype d)))) def) in - {| dname := dname d ; dtype := dtype d ; dbody := eta_expand (ctx ++ Γ) d.(dbody) ; rarg := rarg d |}) + {| dname := dname d ; dtype := dtype d ; dbody := eta_expand (ctx ++ Γ) d.(dbody) ; rarg := rarg d |}) def - in + in match nth_error def' i with | Some d => eta_fixpoint def' i d (map (eta_expand Γ) args) | None => tVar ("Error: lookup of a fixpoint failed for " ++ string_of_term t) end - | tRel n => + | tRel n => match nth_error Γ n with - | Some (Some (c, ty)) => eta_single (tRel n) (map (eta_expand Γ) args) (lift0 (S n) ty) c + | Some (Some (c, ty)) => eta_single (tRel n) (map (eta_expand Γ) args) (lift0 (S n) ty) c | Some None => mkApps (tRel n) (map (eta_expand Γ) args) | _ => tRel n end @@ -118,12 +118,12 @@ Section Eta. | tLetIn na val ty body => tLetIn na (eta_expand Γ val) ty (eta_expand (up Γ) body) | tCase ci p disc brs => let p' := map_predicate id (eta_expand Γ) id p in - let brs' := map (fun b => {| bcontext := bcontext b; bbody := eta_expand (repeat None #|b.(bcontext)| ++ Γ) b.(bbody) |}) brs in + let brs' := map (fun b => {| bcontext := bcontext b; bbody := eta_expand (repeat None #|b.(bcontext)| ++ Γ) b.(bbody) |}) brs in tCase ci p' (eta_expand Γ disc) brs' | tProj p t => tProj p (eta_expand Γ t) - | tFix def i => let def' := (map (fun d => + | tFix def i => let def' := (map (fun d => let ctx := List.rev (mapi (fun (i : nat) d => Some (1 + d.(rarg), (lift0 i (dtype d)))) def) in - {| dname := dname d ; dtype := dtype d ; dbody := eta_expand (ctx ++ Γ) d.(dbody) ; rarg := rarg d |}) def) in + {| dname := dname d ; dtype := dtype d ; dbody := eta_expand (ctx ++ Γ) d.(dbody) ; rarg := rarg d |}) def) in match nth_error def' i with | Some d => eta_fixpoint def' i d [] | None => tVar ("Error: lookup of a fixpoint failed for " @@ -133,7 +133,7 @@ Section Eta. (* NOTE: we know that constructors and constants are not applied at this point, since applications are captured by the previous cases *) | tConstruct ind c u => - match eta_constructor ind c u [] with + match eta_constructor ind c u [] with | Some res => res | None => tVar ("Error: lookup of an inductive failed for " ++ string_of_kername ind.(inductive_mind)) @@ -144,17 +144,17 @@ Section Eta. End Eta. -Definition eta_global_decl Σ cb := - {| cst_type := eta_expand Σ [] cb.(cst_type) ; +Definition eta_global_decl Σ cb := + {| cst_type := eta_expand Σ [] cb.(cst_type) ; cst_universes := cb.(cst_universes) ; cst_body := match cb.(cst_body) with | Some b => Some (eta_expand Σ [] b) | None => None end; cst_relevance := cb.(cst_relevance) |}. - -Definition map_decl_body {term : Type} (f : term -> term) decl := - {| decl_name := decl.(decl_name); + +Definition map_decl_body {term : Type} (f : term -> term) decl := + {| decl_name := decl.(decl_name); decl_type := decl.(decl_type); decl_body := option_map f decl.(decl_body) |}. @@ -164,7 +164,7 @@ Fixpoint fold_context_k_defs {term : Type} (f : nat -> term -> term) (Γ: list ( | d :: Γ => map_decl_body (f #|Γ|) d :: fold_context_k_defs f Γ end. -Lemma context_assumptions_fold_context_k_defs {f : _ -> term -> term} {Γ} : +Lemma context_assumptions_fold_context_k_defs {f : _ -> term -> term} {Γ} : context_assumptions (fold_context_k_defs f Γ) = context_assumptions Γ. Proof. induction Γ; cbn; auto. destruct a as [? [b|] ty]; cbn; auto. @@ -185,7 +185,7 @@ Definition eta_constructor_decl Σ mdecl cdecl := cstr_indices := map (eta_expand Σ []) cdecl.(cstr_indices); cstr_type := eta_expand Σ (repeat None #|mdecl.(ind_bodies)|) cdecl.(cstr_type); cstr_arity := cdecl.(cstr_arity) |}. - + Definition eta_inductive_decl Σ mdecl idecl := {| ind_name := idecl.(ind_name); ind_indices := idecl.(ind_indices); @@ -218,19 +218,19 @@ Definition eta_expand_global_env (Σ : GlobalEnvMap.t) : global_env := retroknowledge := Σ.(retroknowledge) |}. Definition eta_expand_program (p : template_program_env) : Ast.Env.program := - let Σ' := eta_expand_global_env p.1 in + let Σ' := eta_expand_global_env p.1 in (Σ', eta_expand p.1 [] p.2). - + (* Inductive tree := T : list tree -> tree. Fixpoint tmap (f : tree -> tree) (t : tree) := match t with T l => T (map (tmap f) l) end. From MetaCoq.Template Require Import Loader Pretty. -MetaCoq Quote Recursively Definition p := ltac:(let x := eval unfold tmap in tmap in exact (x)). -MetaCoq Unquote Definition q := (eta_expand p.1.(declarations) [] p.2). -Print q. +MetaCoq Quote Recursively Definition p := ltac:(let x := eval unfold tmap in tmap in exact (x)). +MetaCoq Unquote Definition q := (eta_expand p.1.(declarations) [] p.2). +Print q. -Eval lazy in let x := print_term (p.1, Monomorphic_ctx) [] true (eta_expand p.1.(declarations) [] p.2) in +Eval lazy in let x := print_term (p.1, Monomorphic_ctx) [] true (eta_expand p.1.(declarations) [] p.2) in let y := print_term (p.1, Monomorphic_ctx) [] true p.2 in (x,y). @@ -269,13 +269,13 @@ Inductive expanded (Γ : list nat): term -> Prop := ind_npars mind + context_assumptions (cstr_args cdecl) = 0 -> expanded Γ (tConstruct ind idx u) | expanded_tCase (ci : case_info) (type_info:predicate term) - (discr:term) (branches : list (branch term)) : + (discr:term) (branches : list (branch term)) : expanded Γ discr -> Forall (expanded Γ) type_info.(pparams) -> - Forall (fun br => expanded (repeat 0 #|br.(bcontext)| ++ Γ) br.(bbody)) branches -> + Forall (fun br => expanded (repeat 0 #|br.(bcontext)| ++ Γ) br.(bbody)) branches -> expanded Γ (tCase ci type_info discr branches) | expanded_tProj (proj : projection) (t : term) : expanded Γ t -> expanded Γ (tProj proj t) -| expanded_tFix (mfix : mfixpoint term) (idx : nat) args d : +| expanded_tFix (mfix : mfixpoint term) (idx : nat) args d : d.(rarg) < context_assumptions (decompose_prod_assum [] d.(dtype)).1 -> Forall (fun d => isLambda d.(dbody) /\ let ctx := List.rev (mapi (fun (i : nat) d => 1 + d.(rarg)) mfix) in @@ -285,7 +285,7 @@ Inductive expanded (Γ : list nat): term -> Prop := nth_error mfix idx = Some d -> #|args| > d.(rarg) -> expanded Γ (tApp (tFix mfix idx) args) -| expanded_tCoFix (mfix : mfixpoint term) (idx : nat) : +| expanded_tCoFix (mfix : mfixpoint term) (idx : nat) : Forall (fun d => expanded (repeat 0 #|mfix| ++ Γ) d.(dbody)) mfix -> expanded Γ (tCoFix mfix idx) | expanded_tConstruct_app ind c u mind idecl cdecl args : @@ -324,7 +324,7 @@ forall (Σ : global_env) (P : list nat -> term -> Prop), declared_constructor Σ (ind, idx) mind idecl cdecl -> ind_npars mind + context_assumptions (cstr_args cdecl) = 0 -> P Γ (tConstruct ind idx u)) -> -(forall Γ (ci : case_info) (type_info : predicate term) +(forall Γ (ci : case_info) (type_info : predicate term) (discr : term) (branches : list (branch term)), expanded Σ Γ discr -> P Γ discr -> @@ -335,19 +335,19 @@ forall (Σ : global_env) (P : list nat -> term -> Prop), P Γ (tCase ci type_info discr branches)) -> (forall Γ (proj : projection) (t : term), expanded Σ Γ t -> P Γ t -> P Γ (tProj proj t)) -> -(forall Γ (mfix : mfixpoint term) (idx : nat) d args, +(forall Γ (mfix : mfixpoint term) (idx : nat) d args, d.(rarg) < context_assumptions (decompose_prod_assum [] d.(dtype)).1 -> - Forall (fun d => isLambda d.(dbody) /\ let ctx := List.rev (mapi (fun (i : nat) d => 1 + d.(rarg)) mfix) in expanded Σ (ctx ++ Γ) d.(dbody)) mfix -> - Forall (fun d => let ctx := List.rev (mapi (fun (i : nat) d => 1 + d.(rarg)) mfix) in P (ctx ++ Γ)%list d.(dbody)) mfix -> + Forall (fun d => isLambda d.(dbody) /\ let ctx := List.rev (mapi (fun (i : nat) d => 1 + d.(rarg)) mfix) in expanded Σ (ctx ++ Γ) d.(dbody)) mfix -> + Forall (fun d => let ctx := List.rev (mapi (fun (i : nat) d => 1 + d.(rarg)) mfix) in P (ctx ++ Γ)%list d.(dbody)) mfix -> Forall (expanded Σ Γ) args -> Forall (P Γ) args -> args <> [] -> nth_error mfix idx = Some d -> #|args| > d.(rarg) -> P Γ (tApp (tFix mfix idx) args)) -> -(forall Γ (mfix : mfixpoint term) (idx : nat), - Forall (fun d => expanded Σ (repeat 0 #|mfix| ++ Γ) d.(dbody)) mfix -> - Forall (fun d => P (repeat 0 #|mfix| ++ Γ)%list d.(dbody)) mfix -> +(forall Γ (mfix : mfixpoint term) (idx : nat), + Forall (fun d => expanded Σ (repeat 0 #|mfix| ++ Γ) d.(dbody)) mfix -> + Forall (fun d => P (repeat 0 #|mfix| ++ Γ)%list d.(dbody)) mfix -> P Γ (tCoFix mfix idx)) -> (forall Γ (ind : inductive) (c : nat) (u : Instance.t) (mind : mutual_inductive_body) (idecl : one_inductive_body) @@ -356,7 +356,7 @@ forall (Σ : global_env) (P : list nat -> term -> Prop), #|args| >= ind_npars mind + context_assumptions (cstr_args cdecl) -> Forall (expanded Σ Γ) args -> Forall (P Γ) args -> - P Γ(tApp (tConstruct ind c u) args)) -> + P Γ(tApp (tConstruct ind c u) args)) -> (forall Γ i, P Γ (tInt i)) -> (forall Γ f, P Γ (tFloat f)) -> forall Γ, forall t : term, expanded Σ Γ t -> P Γ t. @@ -367,7 +367,7 @@ Proof. all: match goal with [H : Forall _ _ |- _] => let all := fresh "all" in rename H into all end. - eapply HRel_app; eauto. clear - f all. induction all; econstructor; eauto. - eapply HEvar; eauto. clear - f all. induction all; econstructor; eauto. - - eapply HApp; eauto. destruct f0; cbn in *; eauto. + - eapply HApp; eauto. destruct f0; cbn in *; eauto. clear - f all; induction all; econstructor; eauto. - eapply HCase; eauto. induction H; econstructor; eauto. @@ -396,7 +396,7 @@ Record expanded_constructor_decl Σ mdecl cdecl := { expanded_cstr_args : expanded_context Σ (repeat 0 (#|mdecl.(ind_params)| + #|mdecl.(ind_bodies)|)) cdecl.(cstr_args); (* expanded_cstr_indices : All (expanded Σ []) cdecl.(cstr_indices); *) expanded_cstr_type : expanded Σ (repeat 0 #|mdecl.(ind_bodies)|) cdecl.(cstr_type) }. - + Record expanded_inductive_decl Σ mdecl idecl := { (* expanded_ind_type : expanded Σ [] idecl.(ind_type); *) expanded_ind_ctors : Forall (expanded_constructor_decl Σ mdecl) idecl.(ind_ctors) }. @@ -410,10 +410,10 @@ Definition expanded_decl Σ d := | Ast.Env.ConstantDecl cb => expanded_constant_decl Σ cb | Ast.Env.InductiveDecl idecl => expanded_minductive_decl Σ idecl end. - + Inductive expanded_global_declarations (univs : ContextSet.t) (retro : Environment.Retroknowledge.t) : forall (Σ : Ast.Env.global_declarations), Prop := | expanded_global_nil : expanded_global_declarations univs retro [] -| expanded_global_cons decl Σ : expanded_global_declarations univs retro Σ -> +| expanded_global_cons decl Σ : expanded_global_declarations univs retro Σ -> expanded_decl {| Ast.Env.universes := univs; Ast.Env.declarations := Σ; Ast.Env.retroknowledge := retro |} decl.2 -> expanded_global_declarations univs retro (decl :: Σ). @@ -434,7 +434,7 @@ Definition isRel_app t := | tRel _ => true | _ => false end. - + Lemma expanded_fold_lambda Σ Γ t l : expanded Σ Γ (fold_right (fun d (b : term) => tLambda d.(decl_name) d.(decl_type) b) t l) <-> expanded Σ (repeat 0 #|l| ++ Γ) t. @@ -475,7 +475,7 @@ Proof. - congruence. - intros. eapply expanded_tFix; eauto. Qed. - + Lemma expanded_mkApps_tFix_inv Σ Γ mfix idx args : expanded Σ Γ (mkApps (tFix mfix idx) args) -> Forall (fun d0 : def term => isLambda d0.(dbody) /\ let ctx := List.rev (mapi (fun (_ : nat) (d1 : def term) => 1 + rarg d1) mfix) in expanded Σ (ctx ++ Γ) (dbody d0)) mfix. @@ -533,7 +533,7 @@ Lemma expanded_mkApps Σ Γ f args : expanded Σ Γ f -> Forall (expanded Σ Γ) args -> expanded Σ Γ (mkApps f args). Proof. - intros. + intros. eapply expanded_mkApps_inv with (args := []); cbn; eauto. lia. Qed. @@ -546,7 +546,7 @@ Proof. intros; now subst. Qed. Lemma ext_lift n m n' m' t : n' = n -> m' = m -> lift n m t = lift n' m' t. -Proof. intros; now subst. Qed. +Proof. intros; now subst. Qed. Lemma decompose_prod_lift t n m : #|(decompose_prod t).1.1| = #|(decompose_prod (lift n m t)).1.1|. @@ -559,7 +559,7 @@ Qed. Lemma context_assumptions_lift' t Γ Γ' n m : context_assumptions Γ = context_assumptions Γ' -> -context_assumptions (decompose_prod_assum Γ t).1 = +context_assumptions (decompose_prod_assum Γ t).1 = context_assumptions (decompose_prod_assum Γ' (lift n m t)).1. Proof. intros Hlen. @@ -569,7 +569,7 @@ Proof. Qed. Lemma context_assumptions_lift t n m : -context_assumptions (decompose_prod_assum [] t).1 = +context_assumptions (decompose_prod_assum [] t).1 = context_assumptions (decompose_prod_assum [] (lift n m t)).1. Proof. now eapply context_assumptions_lift'. @@ -601,7 +601,7 @@ Proof. + revert Heq. len. lia. - econstructor. solve_all. - econstructor. rewrite app_comm_cons. eapply IHHexp; try reflexivity. - - econstructor; eauto. rewrite app_comm_cons. eapply IHHexp2. 2: now simpl_list. eauto. + - econstructor; eauto. rewrite app_comm_cons. eapply IHHexp2. 2: now simpl_list. eauto. - econstructor; eauto. destruct t; cbn in *; eauto. solve_all. - econstructor; eauto. solve_all. cbn in H0. @@ -610,10 +610,10 @@ Proof. autorewrite with list len in b. now eapply b. - destruct t; invs H8. rewrite !nth_error_map in H5. destruct (nth_error mfix0 idx0) eqn:EE; cbn in H5; invs H5. - eapply expanded_tFix. + eapply expanded_tFix. + shelve. - + eapply Forall_map_inv in H0, H1, H3. cbn in *. - solve_all. now apply isLambda_unlift in H0. rewrite app_assoc. + + eapply Forall_map_inv in H0, H1, H3. cbn in *. + solve_all. now apply isLambda_unlift in H0. rewrite app_assoc. eapply b. autorewrite with list. f_equal. f_equal. rewrite mapi_map. eapply mapi_ext. intros. cbn. reflexivity. f_equal. now len. @@ -645,7 +645,7 @@ Proof. rewrite nth_error_app2; try lia. rewrite <- H. f_equal. lia. + rewrite nth_error_app1 in H |- *; try lia; eauto. - + len. lia. + + len. lia. - econstructor; solve_all. - econstructor. rewrite app_comm_cons. eapply IHexpanded. now simpl_list. - econstructor; eauto. rewrite app_comm_cons. eapply IHexpanded2. now simpl_list. @@ -654,10 +654,10 @@ Proof. - econstructor; eauto. solve_all. cbn; solve_all. solve_all. specialize (a (repeat 0 #|bcontext x| ++ Γ')%list Γ'' Γ). autorewrite with list len in a. now eapply a. - - eapply expanded_tFix. + - eapply expanded_tFix. + shelve. + solve_all. eapply apply_expanded. eapply a. - now rewrite app_assoc. + now rewrite app_assoc. autorewrite with list. f_equal. f_equal. rewrite mapi_map. eapply mapi_ext. intros. cbn. reflexivity. f_equal. now len. @@ -699,7 +699,7 @@ Proof. induction n in l |- *; destruct l; simpl; auto. Qed. -Lemma decompose_prod12 t : +Lemma decompose_prod12 t : #| (decompose_prod t).1.1| = #|(decompose_prod t).1.2|. Proof. induction t; cbn; try lia. @@ -721,7 +721,7 @@ Lemma expanded_eta_single_tRel_app Σ0 n l n0 Γ' T : | Some p => let (n1, _) := p in n1 | None => 0 end) Γ') (eta_single (tRel n) [] T n0) -> - Forall (expanded Σ0 + Forall (expanded Σ0 (map (fun x : option (nat × term) => match x with @@ -785,7 +785,7 @@ Proof. rewrite rev_map_spec. intros. rewrite Forall_forall in H0 |- *. intros. specialize (H0 _ H1). rewrite <- in_rev in H1. - eapply in_map_iff in H1 as (? & <- & [_ ?] % in_seq). + eapply in_map_iff in H1 as (? & <- & [_ ?] % in_seq). invs H0. econstructor. rewrite nth_error_app1. 2: rewrite repeat_length; lia. eapply nth_error_repeat. lia. @@ -841,7 +841,7 @@ Lemma decompose_type_of_constructor : , forall mdecl: mutual_inductive_body , forall idecl: one_inductive_body , forall cdecl: constructor_body -, forall isdecl': declared_constructor Σ0.1 (ind, i) mdecl idecl cdecl, +, forall isdecl': declared_constructor Σ0.1 (ind, i) mdecl idecl cdecl, context_assumptions (decompose_prod_assum [] (type_of_constructor mdecl cdecl (ind, i) u)).1 = ind_npars mdecl + context_assumptions (cstr_args cdecl). Proof. @@ -864,7 +864,7 @@ Proof. rewrite !decompose_prod_assum_it_mkProd. - cbn. rewrite app_nil_r, !context_assumptions_app. now len. - unfold cstr_concl, cstr_concl_head. rewrite Nat.add_0_r. len. - rewrite subst_cstr_concl_head. + rewrite subst_cstr_concl_head. eapply is_ind_app_head_mkApps. eapply nth_error_Some_length; eauto. Qed. @@ -905,7 +905,7 @@ Proof. depind H; eauto. Qed. -Lemma isLambda_eta_expand Σ Γ t : +Lemma isLambda_eta_expand Σ Γ t : isLambda t -> isLambda (eta_expand Σ Γ t). Proof. destruct t; auto. Qed. @@ -916,18 +916,18 @@ Proof. setoid_rewrite <- Nat.add_0_r at 2. rewrite Nat.add_comm. change 0 with (context_assumptions []). generalize (@nil context_decl). - induction t; cbn; intros; try lia; len. + induction t; cbn; intros; try lia; len. - destruct (decompose_prod t2) as [[]]; cbn in *. rewrite IHt2. cbn; lia. - rewrite IHt3. cbn. lia. *) - + Import EnvMap. -Definition repr_decls Σg Σ := +Definition repr_decls Σg Σ := forall kn d, lookup_global Σ.(declarations) kn = Some d -> GlobalEnvMap.lookup_env Σg kn = Some d. Import ssreflect. -Lemma repr_lookup_constructor {Σg Σ} : +Lemma repr_lookup_constructor {Σg Σ} : repr_decls Σg Σ -> forall ind idx r, lookup_constructor Σ ind idx = Some r -> GlobalEnvMap.lookup_constructor Σg ind idx = Some r. Proof. @@ -942,7 +942,7 @@ Import bytestring.String. Local Open Scope bs. -Lemma constructor_declared {cf : checker_flags} {Σ Γ ind idx u ty} : +Lemma constructor_declared {cf : checker_flags} {Σ Γ ind idx u ty} : Σ ;;; Γ |- tConstruct ind idx u : ty -> exists r, lookup_constructor Σ ind idx = Some r. Proof. @@ -958,8 +958,8 @@ Lemma eta_expand_expanded {cf : config.checker_flags} {Σ : global_env_ext} Γ expanded Σ (map (fun x => match x with Some (n, _) => n | None => 0 end ) Γ') (eta_expand Σg Γ' t). Proof. intros wf Hty. revert Γ'. - eapply @typing_ind_env with (t := t) (Σ := Σ) - (P := fun (Σ : global_env_ext) Γ t T => forall Γ', Forall2 (fun (x : option (nat × term)) (y : context_decl) => + eapply @typing_ind_env with (t := t) (Σ := Σ) + (P := fun (Σ : global_env_ext) Γ t T => forall Γ', Forall2 (fun (x : option (nat × term)) (y : context_decl) => match x with | Some (_, t0) => decl_type y = t0 /\ _ | None => True @@ -969,7 +969,7 @@ Proof. match x with | Some (n, _) => n | None => 0 - end) Γ') (eta_expand Σg Γ' t)) + end) Γ') (eta_expand Σg Γ' t)) (PΓ := fun _ _ _ => True); repeat match goal with | [ |- repr_decls _ _ -> _ ] => intros hrepr @@ -977,18 +977,18 @@ Proof. end; try now (cbn; eauto). - cbn. eapply Forall2_nth_error_Some_r in H1 as (? & ? & ?); eauto. rewrite H1. - destruct x as [[] | ]. + destruct x as [[] | ]. + destruct H2. unfold eta_single. cbn. eapply expanded_fold_lambda. rewrite !Nat.sub_0_r. len. rewrite firstn_length. len. destruct n0. - * cbn. econstructor. now rewrite nth_error_map H1. + * cbn. econstructor. now rewrite nth_error_map H1. * rewrite seq_S rev_map_spec map_app rev_app_distr. subst. rewrite <- context_assumptions_lift, !Nat.min_l; try lia. econstructor. -- rewrite nth_error_app2 repeat_length; try lia. replace (S n0 + n - S n0) with n by lia. - now rewrite nth_error_map H1. + now rewrite nth_error_map H1. -- len. now rewrite seq_length. -- eapply Forall_forall. intros x [ | (? & <- & [_ ?] % in_seq) % in_rev % in_map_iff]; subst. all: econstructor; rewrite nth_error_app1; revgoals; [eapply nth_error_repeat; lia | rewrite repeat_length; lia]. @@ -1001,7 +1001,7 @@ Proof. match x with | Some p => let (n, _) := p in n | None => 0 - end) Γ') (eta_expand Σg Γ' t)) l). { + end) Γ') (eta_expand Σg Γ' t)) l). { clear H1. clear X. induction X0; econstructor; eauto. } destruct t0; cbn. all: try now eapply expanded_mkApps; [ eauto | solve_all ]. @@ -1010,8 +1010,8 @@ Proof. destruct o; eauto. destruct p. cbn in *. eapply expanded_eta_single_tRel_app; eauto. solve_all. - eapply Forall2_nth_error_Some_l in H2 as (? & ? & ?). 2: eauto. - cbn in *. + eapply Forall2_nth_error_Some_l in H2 as (? & ? & ?). 2: eauto. + cbn in *. destruct H4. rewrite <- context_assumptions_lift. subst. lia. cbn. eapply expanded_mkApps. constructor. @@ -1038,7 +1038,7 @@ Proof. eapply expanded_mkApps_tConstruct. now eapply lookup_constructor_declared. rewrite rev_map_spec. simpl_list. rewrite EE. lia. eapply Forall_typing_spine_Forall in X0. assert ((context_assumptions - (decompose_prod_assum [] (type_of_constructor mdecl cdecl (ind, idx) u)).1) = ind_npars mdecl + context_assumptions (cstr_args cdecl)) as E. { + (decompose_prod_assum [] (type_of_constructor mdecl cdecl (ind, idx) u)).1) = ind_npars mdecl + context_assumptions (cstr_args cdecl)) as E. { eapply decompose_type_of_constructor; eauto. now eapply lookup_constructor_declared. } eapply app_Forall. @@ -1048,7 +1048,7 @@ Proof. rewrite E EE. lia. } cbn. eauto. - -- rewrite rev_map_spec. eapply Forall_rev. + -- rewrite rev_map_spec. eapply Forall_rev. eapply Forall_forall. intros ? (? & <- & ?) % in_map_iff. econstructor. eapply in_seq in H4 as [_ H4]. len. rewrite nth_error_app1; len. @@ -1061,12 +1061,12 @@ Proof. cbn in H. unfold eta_fixpoint in *. rewrite nth_error_map in H |- *. destruct (nth_error mfix idx) eqn:Eid; eauto. - cbn in *. - eapply expanded_fold_lambda. - + cbn in *. + eapply expanded_fold_lambda. + eapply expanded_mkApps_tFix; fold lift. 2:{ rewrite !nth_error_map Eid. cbn. len. reflexivity. } - ++ cbn. rewrite <- context_assumptions_lift. + ++ cbn. rewrite <- context_assumptions_lift. eapply wf_fixpoint_rarg; eauto. 2: eapply nth_error_In; eauto. clear - X. depind X; eauto. ++ len. rewrite seq_length. lia. @@ -1077,9 +1077,9 @@ Proof. eapply expanded_mkApps_tFix_inv in H. eapply Forall_forall. intros ? (? & <- & (? & <- & ?) % in_map_iff) % in_map_iff. cbn. - - - eapply Forall_forall in H. 2:{ + + + eapply Forall_forall in H. 2:{ eapply in_map_iff. eexists. split. reflexivity. eapply in_map_iff. eexists. split. cbn. reflexivity. eauto. } cbn in H. revert H. len. intros [Hl H]. split. @@ -1115,24 +1115,24 @@ Proof. eapply typing_wf_fixpoint in X. eapply wf_fixpoint_rarg in X. 2: eauto. 2: eapply nth_error_In; eauto. len. lia. - ** rewrite rev_map_spec. eapply Forall_rev. + ** rewrite rev_map_spec. eapply Forall_rev. eapply Forall_forall. intros ? (? & <- & ?) % in_map_iff. econstructor. eapply in_seq in H4 as [_ H4]. autorewrite with len in H4 |- *. rewrite !firstn_length !List.skipn_length. rewrite -> nth_error_app1. eapply nth_error_repeat. - -- len. + -- len. eapply Nat.lt_le_trans. eauto. cbn. eapply typing_wf_fixpoint in X. eapply wf_fixpoint_rarg in X. 2: eauto. 2: eapply nth_error_In; eauto. lia. - -- len. + -- len. eapply Nat.lt_le_trans. eauto. cbn. eapply typing_wf_fixpoint in X. eapply wf_fixpoint_rarg in X. 2: eauto. 2: eapply nth_error_In; eauto. lia. - ++ destruct l; cbn in *; try congruence. + ++ destruct l; cbn in *; try congruence. ++ cbn. eauto. - - cbn. pose proof isdecl as isdecl'. + - cbn. pose proof isdecl as isdecl'. unfold eta_constructor. eapply declared_constructor_lookup in isdecl'. eapply (repr_lookup_constructor hrepr) in isdecl'. rewrite isdecl'. @@ -1160,20 +1160,20 @@ Proof. + constructor. + constructor; auto. eapply t1; solve_all; auto. + auto. - + * solve_all. specialize (b (repeat None #|bcontext y| ++ Γ'))%list. rewrite map_app map_repeat in b. eapply b; eauto. eapply Forall2_app; solve_all. - - assert (#| (case_branch_context_gen (ci_ind ci) mdecl (pparams p) + + assert (#| (case_branch_context_gen (ci_ind ci) mdecl (pparams p) (puinst p) (bcontext y) x)| = #|bcontext y|). { clear - a0. unfold case_branch_context_gen. rewrite map2_length. rewrite Nat.min_l; try lia. eapply All2_length in a0. unfold inst_case_context. unfold subst_context. unfold subst_instance, subst_instance_context, map_context. rewrite fold_context_k_length map_length. unfold aname. lia. - } revert H9. generalize ((case_branch_context_gen (ci_ind ci) mdecl (pparams p) + } revert H9. generalize ((case_branch_context_gen (ci_ind ci) mdecl (pparams p) (puinst p) (bcontext y) x)). clear -hrepr. induction #|bcontext y|; intros []; cbn; intros; try congruence; econstructor; eauto. - cbn. rewrite nth_error_map H0. cbn. unfold eta_fixpoint. unfold fst_ctx in *. cbn in *. @@ -1232,7 +1232,7 @@ Fixpoint lookup_global_env (Σ : global_declarations) (kn : kername) {struct Σ} | d :: tl => if kn == d.1 then Some (d.2, tl) else lookup_global_env tl kn end. -Lemma lookup_lookup_global_env Σ kn decl : +Lemma lookup_lookup_global_env Σ kn decl : lookup_global Σ kn = Some decl -> ∑ Σ', lookup_global_env Σ kn = Some (decl, Σ'). Proof. induction Σ => // /=. @@ -1242,7 +1242,7 @@ Proof. auto. Qed. -Lemma lookup_global_env_lookup Σ kn dΣ : +Lemma lookup_global_env_lookup Σ kn dΣ : lookup_global_env Σ kn = Some dΣ -> lookup_global Σ kn = Some dΣ.1. Proof. induction Σ => // /=. @@ -1252,7 +1252,7 @@ Proof. auto. Qed. -Lemma lookup_lookup_global_env_None Σ kn : +Lemma lookup_lookup_global_env_None Σ kn : lookup_global Σ kn = None <-> lookup_global_env Σ kn = None. Proof. induction Σ => // /=. @@ -1282,7 +1282,7 @@ Proof. Qed. Lemma eta_lookup_global_error Σ ind : - lookup_global (eta_global_declarations Σ Σ.(declarations)) (inductive_mind ind) = None -> + lookup_global (eta_global_declarations Σ Σ.(declarations)) (inductive_mind ind) = None -> lookup_global Σ.(declarations) (inductive_mind ind) = None. Proof. unfold eta_global_declarations. @@ -1291,7 +1291,7 @@ Qed. Lemma eta_declared_constructor {Σ : GlobalEnvMap.t} {ind mdecl idecl cdecl} : declared_constructor Σ ind mdecl idecl cdecl -> - declared_constructor (eta_expand_global_env Σ) ind (eta_minductive_decl Σ mdecl) + declared_constructor (eta_expand_global_env Σ) ind (eta_minductive_decl Σ mdecl) (eta_inductive_decl Σ mdecl idecl) (eta_constructor_decl Σ mdecl cdecl). Proof. rewrite /declared_constructor. @@ -1306,17 +1306,17 @@ Qed. Import ssreflect ssrbool. -Definition same_cstr_info Σ Σ' := - forall ind idx mdecl idecl cdecl, - declared_constructor Σ (ind, idx) mdecl idecl cdecl -> - exists mdecl' idecl' cdecl', +Definition same_cstr_info Σ Σ' := + forall ind idx mdecl idecl cdecl, + declared_constructor Σ (ind, idx) mdecl idecl cdecl -> + exists mdecl' idecl' cdecl', [/\ declared_constructor Σ' (ind, idx) mdecl' idecl' cdecl', mdecl.(ind_npars) = mdecl'.(ind_npars) & context_assumptions cdecl.(cstr_args) = context_assumptions cdecl'.(cstr_args)]. - -Lemma expanded_env_irrel Σ Σ' Γ t : + +Lemma expanded_env_irrel Σ Σ' Γ t : same_cstr_info Σ Σ' -> - expanded Σ Γ t -> + expanded Σ Γ t -> expanded Σ' Γ t. Proof. intros hrepr. @@ -1330,9 +1330,9 @@ Proof. eapply expanded_tConstruct_app; tea. cbn. lia. Qed. -Lemma expanded_context_env_irrel Σ Σ' Γ t : +Lemma expanded_context_env_irrel Σ Σ' Γ t : same_cstr_info Σ Σ' -> - expanded_context Σ Γ t -> + expanded_context Σ Γ t -> expanded_context Σ' Γ t. Proof. unfold expanded_decl. @@ -1341,9 +1341,9 @@ Proof. eapply expanded_env_irrel; tea. Qed. -Lemma expanded_decl_env_irrel (Σ Σ' : global_env) t : +Lemma expanded_decl_env_irrel (Σ Σ' : global_env) t : same_cstr_info Σ Σ' -> - expanded_decl Σ t -> + expanded_decl Σ t -> expanded_decl Σ' t. Proof. intros hrepr. @@ -1421,11 +1421,11 @@ Qed. Lemma eta_expand_context_sorts {cf} {Σ} {Σg : global_env_ext_map} {ctx ctx' cunivs} {wfΣ : Typing.wf_ext Σ} : repr_decls Σg Σ -> - sorts_local_ctx (lift_typing typing) Σ ctx ctx' cunivs -> + sorts_local_ctx (lift_typing typing) Σ ctx ctx' cunivs -> expanded_context Σ (repeat 0 #|ctx|) (eta_context Σg #|ctx| ctx'). Proof. intros hrepr hs. constructor. - eapply All_fold_fold_context_k_defs. cbn. len. + eapply All_fold_fold_context_k_defs. cbn. len. induction ctx' in hs, cunivs |- *; cbn; auto. constructor; eauto. cbn in hs. destruct a as [na [b|] ty]; try destruct hs as [hs ?]. @@ -1472,7 +1472,7 @@ Proof. constructor. cbn. len. pose proof onc.(on_cargs). eapply eta_expand_context_sorts in X0. now len in X0. exact hrepr. - len. len. + len. len. pose proof onc.(on_ctype). destruct X0. epose proof (eta_expand_expanded (Σ := Σ) _ (repeat None #|ind_bodies m|) _ _ wf t0). forward H. rewrite -arities_context_length. @@ -1487,8 +1487,8 @@ Proof. Qed. Lemma same_cstr_info_eta (Σ : global_env) (Σg: GlobalEnvMap.t) : - same_cstr_info Σ - {| universes := Σ.(universes) ; + same_cstr_info Σ + {| universes := Σ.(universes) ; declarations := List.map (on_snd (eta_global_declaration Σg)) Σ.(declarations); retroknowledge := Σ.(retroknowledge) |}. Proof. @@ -1498,7 +1498,7 @@ Proof. cbn => [[[]]] //. - unfold declared_constructor, declared_inductive, declared_minductive. cbn. destruct a as [kn decl]; cbn. - case: eqb_spec. + case: eqb_spec. * move=> _ [] [] [= ->] hnth hnth'. do 3 eexists; cbn. split. split. split => //. cbn. rewrite nth_error_map hnth; reflexivity. @@ -1529,13 +1529,13 @@ Proof. apply lookup_global_Some_fresh. Qed. -Lemma lookup_global_extends Σ Σ' kn d : +Lemma lookup_global_extends Σ Σ' kn d : lookup_env Σ kn = Some d -> extends_decls Σ Σ' -> EnvMap.fresh_globals Σ'.(declarations) -> lookup_env Σ' kn = Some d. Proof. - destruct Σ as [univs Σ retro]. + destruct Σ as [univs Σ retro]. destruct Σ' as [univs' Σ' retro']. cbn. move=> hl [] /=; intros <- [Σ'' ->] extretro. induction Σ''; cbn; auto. @@ -1562,7 +1562,7 @@ Proof. destruct env as [univs' decls retro']. cbn in *. induction ond; cbn; constructor; auto. apply: IHond. - { cbn. destruct X as [equ [Σ' ext]]. red. split. auto. + { cbn. destruct X as [equ [Σ' ext]]. red. split. auto. rewrite ext. cbn. unfold snoc. exists (Σ' ++ [(kn, d)])%list. now rewrite -app_assoc. apply e. } set (Σ' := {| universes := univs'; declarations := Σ; retroknowledge := retro' |}) in *. diff --git a/template-coq/theories/Kernames.v b/template-coq/theories/Kernames.v index 4fa632bef..92f54dedd 100644 --- a/template-coq/theories/Kernames.v +++ b/template-coq/theories/Kernames.v @@ -51,7 +51,7 @@ Module DirPathOT := ListOrderedType IdentOT. #[global] Instance dirpath_eqdec : Classes.EqDec dirpath := _. -Definition string_of_dirpath (dp : dirpath) : string := +Definition string_of_dirpath (dp : dirpath) : string := String.concat "." (List.rev dp). (** The module part of the kernel name. @@ -94,9 +94,9 @@ Module ModPathComp. Fixpoint compare mp mp' := match mp, mp' with | MPfile dp, MPfile dp' => DirPathOT.compare dp dp' - | MPbound dp id k, MPbound dp' id' k' => + | MPbound dp id k, MPbound dp' id' k' => mpbound_compare dp id k dp' id' k' - | MPdot mp id, MPdot mp' id' => + | MPdot mp id, MPdot mp' id' => compare_cont (compare mp mp') (IdentOT.compare id id') | MPfile _, _ => Gt | _, MPfile _ => Lt @@ -142,7 +142,7 @@ Module ModPathComp. destruct (x ?= y); simpl; auto. apply IdentOT.compare_sym. Qed. - + Lemma nat_compare_trans : forall c x y z, Nat.compare x y = c -> Nat.compare y z = c -> Nat.compare x z = c. Proof. @@ -151,7 +151,7 @@ Module ModPathComp. destruct (PeanoNat.Nat.compare_spec y z); subst; try congruence; destruct (PeanoNat.Nat.compare_spec x z); subst; try congruence; lia. Qed. - + Lemma compare_trans : forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. Proof. @@ -179,7 +179,7 @@ Module ModPathComp. rewrite (IHx _ _ _ eq eq') //. destruct (y ?= z) eqn:eq'; cbn; auto; try congruence. apply compare_eq in eq'; subst. - intros eq'. now rewrite eq. + intros eq'. now rewrite eq. now rewrite (IHx _ _ _ eq eq'). Qed. @@ -187,7 +187,7 @@ End ModPathComp. Module ModPathOT := OrderedType_from_Alt ModPathComp. -Program Definition modpath_eq_dec (x y : modpath) : { x = y } + { x <> y } := +Program Definition modpath_eq_dec (x y : modpath) : { x = y } + { x <> y } := match ModPathComp.compare x y with | Eq => left _ | _ => right _ @@ -209,9 +209,9 @@ Module KernameComp. Lemma eq_equiv : RelationClasses.Equivalence eq. Proof. apply _. Qed. - Definition compare kn kn' := + Definition compare kn kn' := match kn, kn' with - | (mp, id), (mp', id') => + | (mp, id), (mp', id') => compare_cont (ModPathComp.compare mp mp') (IdentOT.compare id id') end. @@ -224,15 +224,15 @@ Module KernameComp. rewrite ModPathComp.compare_sym IdentOT.compare_sym. destruct ModPathComp.compare, IdentOT.compare; auto. Qed. - + Lemma compare_trans : forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. Proof. intros c [] [] [] => /=. - eapply compare_cont_trans; eauto using ModPathComp.compare_trans, ModPathComp.compare_eq, + eapply compare_cont_trans; eauto using ModPathComp.compare_trans, ModPathComp.compare_eq, StringOT.compare_trans. Qed. - + End KernameComp. Module Kername. @@ -256,7 +256,7 @@ Module Kername. Definition compare_spec : forall x y, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). Proof. induction x; destruct y. - simpl. + simpl. destruct (ModPathComp.compare a m) eqn:eq. destruct (IdentOT.compare b i) eqn:eq'. all:constructor. red. eapply ModPathComp.compare_eq in eq. eapply string_compare_eq in eq'. congruence. @@ -274,7 +274,7 @@ Module Kername. now apply irreflexivity in H. Qed. - Definition eqb kn kn' := + Definition eqb kn kn' := match compare kn kn' with | Eq => true | _ => false @@ -289,7 +289,7 @@ Module Kername. -intros e'; subst. now rewrite OT.eq_refl in e. -intros e'; subst. now rewrite OT.eq_refl in e. Defined. - + Definition eq_dec : forall (x y : t), { x = y } + { x <> y } := Classes.eq_dec. End Kername. @@ -308,12 +308,12 @@ Definition eq_constant := eq_kername. (* Local Open Scope string_scope.*) (* Eval compute in KernameOT.compare (MPfile ["fdejrkjl"], "A") (MPfile ["lfrk;k"], "B"). *) - + Module KernameSet := MSetAVL.Make Kername. Module KernameSetFact := MSetFacts.WFactsOn Kername KernameSet. Module KernameSetProp := MSetProperties.WPropertiesOn Kername KernameSet. -Lemma knset_in_fold_left {A} kn f (l : list A) acc : +Lemma knset_in_fold_left {A} kn f (l : list A) acc : KernameSet.In kn (fold_left (fun acc x => KernameSet.union (f x) acc) l acc) <-> (KernameSet.In kn acc \/ exists a, In a l /\ KernameSet.In kn (f a)). Proof. @@ -365,7 +365,7 @@ Record projection := mkProjection proj_npars : nat; (* Number of (non-let) parameters *) proj_arg : nat (* Argument to project *) }. -Definition eq_projection (p p' : projection) := +Definition eq_projection (p p' : projection) := (p.(proj_ind), p.(proj_npars), p.(proj_arg)) == (p'.(proj_ind), p'.(proj_npars), p'.(proj_arg)). #[global, program] Instance reflect_eq_projection : ReflectEq projection := { @@ -410,7 +410,7 @@ Definition gref_eqb (x y : global_reference) : bool := | _, _ => false end. -#[global, program] Instance grep_reflect_eq : ReflectEq global_reference := +#[global, program] Instance grep_reflect_eq : ReflectEq global_reference := {| eqb := gref_eqb |}. Next Obligation. destruct x, y; cbn; try constructor; try congruence. diff --git a/template-coq/theories/LiftSubst.v b/template-coq/theories/LiftSubst.v index 5a506f748..76fdf91dd 100644 --- a/template-coq/theories/LiftSubst.v +++ b/template-coq/theories/LiftSubst.v @@ -148,7 +148,7 @@ Lemma permute_lift : Proof. intros M. elim M using term_forall_list_ind; - intros; simpl; + intros; simpl; rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?Nat.add_assoc, ?map_predicate_map_predicate, ?map_branches_map_branches; f_equal; try solve [auto; solve_all]; repeat nth_leb_simpl. @@ -313,7 +313,7 @@ Proof. - unfold subst at 2. elim (leb_spec p n); intros; try easy. - + + destruct (nth_error_spec N (n - p)). ++ rewrite -> subst_rel_lt by lia. erewrite subst_rel_eq; try easy. @@ -403,7 +403,7 @@ Lemma simpl_subst_k Σ (N : list term) (M : term) : wf Σ M -> forall k p, p = #|N| -> subst N k (lift p k M) = M. Proof. intros. subst p. rewrite <- (Nat.add_0_r #|N|). - erewrite simpl_subst_rec, lift0_id; eauto. + erewrite simpl_subst_rec, lift0_id; eauto. Qed. Lemma subst_app_decomp Σ l l' k t : @@ -423,7 +423,7 @@ Proof. rewrite -> permute_lift by auto. rewrite <- (Nat.add_0_r #|l'|). erewrite -> simpl_subst_rec, lift0_id; auto with wf; try lia. apply wf_lift. - eapply nth_error_all in e; eauto. + eapply nth_error_all in e; eauto. Qed. Lemma subst_app_simpl Σ l l' k t : @@ -457,16 +457,16 @@ Proof. intros. unfold map_decl, vass; simpl; f_equal. rewrite permute_lift. lia. f_equal; lia. Qed. -(* -Lemma noccur_between_subst k n t : noccur_between k n t -> +(* +Lemma noccur_between_subst k n t : noccur_between k n t -> closedn (n + k) t -> closedn k t. Proof. Qed. *) (* TODO *) -Lemma strip_casts_lift n k t : +Lemma strip_casts_lift n k t : strip_casts (lift n k t) = lift n k (strip_casts t). Proof. - induction t in k |- * using term_forall_list_ind; simpl; auto; + induction t in k |- * using term_forall_list_ind; simpl; auto; rewrite ?map_map_compose ?compose_on_snd ?compose_map_def ?map_length; f_equal; solve_all; eauto. @@ -481,13 +481,13 @@ Lemma mkApps_ex t u l : ∑ f args, Ast.mkApps t (u :: l) = Ast.tApp f args. Proof. induction t; simpl; eexists _, _; reflexivity. Qed. -(* +(* Lemma mkApps_tApp' f l l' : mkApps (tApp f l) l' = mkApps f (l ++ l'). Proof. induction l'; simpl. rewrite app_nil_r. *) Lemma list_length_ind {A} (P : list A -> Type) (p0 : P []) - (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (d :: Γ)) + (pS : forall d Γ, (forall Γ', #|Γ'| <= #|Γ| -> P Γ') -> P (d :: Γ)) Γ : P Γ. Proof. generalize (le_n #|Γ|). @@ -500,7 +500,7 @@ Proof. apply p0. apply pS. intros. apply IHn. simpl. lia. Qed. -Lemma strip_casts_mkApps_tApp f l : +Lemma strip_casts_mkApps_tApp f l : isApp f = false -> strip_casts (mkApps f l) = strip_casts (tApp f l). Proof. @@ -509,7 +509,7 @@ Proof. rewrite mkApps_tApp //. Qed. -Lemma strip_casts_mkApps f l : +Lemma strip_casts_mkApps f l : isApp f = false -> strip_casts (mkApps f l) = mkApps (strip_casts f) (map strip_casts l). Proof. diff --git a/template-coq/theories/Normal.v b/template-coq/theories/Normal.v index 15c5ca8e7..2471d6dc4 100644 --- a/template-coq/theories/Normal.v +++ b/template-coq/theories/Normal.v @@ -29,7 +29,7 @@ Section Normal. lookup_env Σ c = Some (ConstantDecl decl) -> decl.(cst_body) = None -> neutral Γ (tConst c u) | ne_app f v : neutral Γ f -> Forall (normal Γ) v -> neutral Γ (tApp f v) - | ne_case i p c brs : neutral Γ c -> + | ne_case i p c brs : neutral Γ c -> (* FIXME context of the branch can contain let-ins *) Forall (normal Γ ∘ bbody) brs -> neutral Γ (tCase i p c brs) diff --git a/template-coq/theories/Pretty.v b/template-coq/theories/Pretty.v index 3a3c37dd9..c40e3604a 100644 --- a/template-coq/theories/Pretty.v +++ b/template-coq/theories/Pretty.v @@ -63,8 +63,8 @@ Section print_term. Definition fresh_name (Γ : list ident) (na : name) (t : option term) : ident := let id := match na with | nNamed id => id - | nAnon => - match t with + | nAnon => + match t with | Some t => name_from_term t | None => "_" end @@ -75,12 +75,12 @@ Section print_term. Definition fix_context (m : mfixpoint term) : context := List.rev (mapi (fun i d => vass d.(dname) (lift0 i d.(dtype))) m). - + Definition rename_decl (na : aname) (decl : context_decl) : context_decl := {| decl_name := na; decl_type := decl_type decl; decl_body := decl_body decl |}. - + Definition build_return_context (ind : inductive) (oib : one_inductive_body) @@ -198,7 +198,7 @@ Module PrintTermTree. match build_return_context ind oib p with | None => "Case(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_term t ^ "," - ^ string_of_predicate string_of_term p ^ "," ^ + ^ string_of_predicate string_of_term p ^ "," ^ string_of_list (pretty_string_of_branch string_of_term) brs ^ ")" | Some Γret => @@ -219,7 +219,7 @@ Module PrintTermTree. let brs := map (fun br => print_branch Γ (List.rev br.(bcontext)) (fun Γ => print_term Γ true br.(bbody))) brs in let brs := combine brs oib.(ind_ctors) in - + parens top ("match " ^ print_term Γ true t ^ " as " ^ as_name ^ " in " ^ in_str ^ @@ -230,7 +230,7 @@ Module PrintTermTree. end | None => "Case(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_term t ^ "," - ^ string_of_predicate string_of_term p ^ "," ^ + ^ string_of_predicate string_of_term p ^ "," ^ string_of_list (pretty_string_of_branch string_of_term) brs ^ ")" end | tProj p c => @@ -254,7 +254,7 @@ Module PrintTermTree. Definition pr_context_decl Γ (c : context_decl) : ident * t := match c with - | {| decl_name := na; decl_type := ty; decl_body := None |} => + | {| decl_name := na; decl_type := ty; decl_body := None |} => let na' := (fresh_name Σ Γ na.(binder_name) (Some ty)) in (na', ("(" ^ na' ^ " : " ^ print_term Γ true ty ^ ")")) | {| decl_name := na; decl_type := ty; decl_body := Some b |} => @@ -266,7 +266,7 @@ Module PrintTermTree. Fixpoint print_context Γ Δ : list ident * t := match Δ with | [] => (Γ, "" : t) - | d :: decls => + | d :: decls => let '(Γ, s) := print_context Γ decls in let '(na, s') := pr_context_decl Γ d in match decls with @@ -278,17 +278,17 @@ Module PrintTermTree. Definition print_one_cstr Γ (mib : mutual_inductive_body) (c : constructor_body) : t := let '(Γargs, s) := print_context Γ c.(cstr_args) in c.(cstr_name) ^ " : " ^ s ^ "_" ^ print_list (print_term Γargs true) " " c.(cstr_indices). - + Definition print_one_ind (short : bool) Γ (mib : mutual_inductive_body) (oib : one_inductive_body) : t := let '(Γpars, spars) := print_context Γ mib.(ind_params) in let '(Γinds, sinds) := print_context Γpars oib.(ind_indices) in oib.(ind_name) ^ spars ^ sinds ^ print_term Γinds true (tSort oib.(ind_sort)) ^ ":=" ^ nl ^ if short then "..." else print_list (print_one_cstr Γpars mib) nl oib.(ind_ctors). - + Definition print_one_cstr_entry Γ (mie : mutual_inductive_entry) (c : ident × term) : t := c.1 ^ " : " ^ print_term Γ true c.2. - + Definition print_one_ind_entry (short : bool) Γ (mie : mutual_inductive_entry) (oie : one_inductive_entry) : t := let '(Γpars, spars) := print_context Γ mie.(mind_entry_params) in oie.(mind_entry_typename) ^ spars ^ print_term Γpars true oie.(mind_entry_arity) ^ ":=" ^ nl ^ @@ -312,40 +312,40 @@ Module PrintTermTree. Definition print_mib Σ with_universes (short : bool) (mib : mutual_inductive_body) : t := let Σ' := (Σ, mib.(ind_universes)) in let names := fresh_names Σ' [] (arities_context mib.(ind_bodies)) in - (print_recursivity_kind mib.(ind_finite) ^ " " ^ + (print_recursivity_kind mib.(ind_finite) ^ " " ^ print_list (print_one_ind Σ' with_universes short names mib) (nl ^ "with ") mib.(ind_bodies) ^ "." ^ nl). - Definition mie_arities_context mie := - rev_map (fun ind => vass (mkBindAnn (nNamed ind.(mind_entry_typename)) Relevant) - (it_mkProd_or_LetIn mie.(mind_entry_params) ind.(mind_entry_arity))) + Definition mie_arities_context mie := + rev_map (fun ind => vass (mkBindAnn (nNamed ind.(mind_entry_typename)) Relevant) + (it_mkProd_or_LetIn mie.(mind_entry_params) ind.(mind_entry_arity))) mie.(mind_entry_inds). - + Definition print_mie Σ with_universes (short : bool) (mie : mutual_inductive_entry) : t := let Σ' := (Σ, universes_decl_of_universes_entry mie.(mind_entry_universes)) in let names := fresh_names Σ' [] (mie_arities_context mie) in (print_recursivity_kind mie.(mind_entry_finite) ^ " " ^ print_list (print_one_ind_entry Σ' with_universes short names mie) (nl ^ "with ") mie.(mind_entry_inds) ^ "." ^ nl). - - Fixpoint print_env_aux with_universes (short : bool) (prefix : nat) (Σ : global_env) (acc : t) : t := - match prefix with + + Fixpoint print_env_aux with_universes (short : bool) (prefix : nat) (Σ : global_env) (acc : t) : t := + match prefix with | 0 => match Σ.(declarations) with [] => acc | _ => ("..." ^ nl ^ acc) end - | S n => + | S n => let univs := Σ.(Env.universes) in let retro := Σ.(Env.retroknowledge) in match Σ.(declarations) with | [] => acc - | (kn, InductiveDecl mib) :: Σ => + | (kn, InductiveDecl mib) :: Σ => let Σ := {| Env.universes := univs; declarations := Σ; retroknowledge := retro |} in print_env_aux with_universes short n Σ (print_mib Σ with_universes short mib ^ acc) | (kn, ConstantDecl cb) :: Σ => let Σ' := ({| Env.universes := univs; declarations := Σ; retroknowledge := retro |}, cb.(cst_universes)) in print_env_aux with_universes short n Σ'.1 - ((match cb.(cst_body) with + ((match cb.(cst_body) with | Some _ => "Definition " | None => "Axiom " end) ^ string_of_kername kn ^ " : " ^ print_term Σ' with_universes nil true cb.(cst_type) ^ match cb.(cst_body) with - | Some b => + | Some b => if short then ("..." ^ nl) else (" := " ^ nl ^ print_term Σ' with_universes nil true b ^ "." ^ nl) | None => "." @@ -353,11 +353,11 @@ Module PrintTermTree. end end. - Definition print_env with_universes (short : bool) (prefix : nat) Σ := + Definition print_env with_universes (short : bool) (prefix : nat) Σ := print_env_aux with_universes short prefix Σ (Tree.string ""). - Definition print_program with_universes (short : bool) (prefix : nat) (p : program) : t := - print_env with_universes short prefix (fst p) ^ nl ^ print_term (empty_ext (fst p)) with_universes nil true (snd p). + Definition print_program with_universes (short : bool) (prefix : nat) (p : program) : t := + print_env with_universes short prefix (fst p) ^ nl ^ print_term (empty_ext (fst p)) with_universes nil true (snd p). End PrintTermTree. @@ -366,8 +366,8 @@ Definition print_mib Σ with_universes short := Tree.to_string ∘ PrintTermTree Definition print_term Σ Γ top := Tree.to_string ∘ PrintTermTree.print_term Σ true Γ top. -Definition print_env (short : bool) (prefix : nat) Σ := +Definition print_env (short : bool) (prefix : nat) Σ := Tree.to_string (PrintTermTree.print_env true short prefix Σ). -Definition print_program (short : bool) (prefix : nat) (p : program) : string := +Definition print_program (short : bool) (prefix : nat) (p : program) : string := Tree.to_string (PrintTermTree.print_program true short prefix p). diff --git a/template-coq/theories/Primitive.v b/template-coq/theories/Primitive.v index 818ac49dc..5120dea6e 100644 --- a/template-coq/theories/Primitive.v +++ b/template-coq/theories/Primitive.v @@ -4,13 +4,13 @@ From Coq Require Import Uint63 PrimFloat SpecFloat FloatOps ZArith HexadecimalSt From MetaCoq.Template Require Import bytestring MCString. Local Open Scope bs. -Variant prim_tag := +Variant prim_tag := | primInt | primFloat. (* | primArray. *) Derive NoConfusion EqDec for prim_tag. -Definition string_of_prim_int (i:Uint63.int) : string := +Definition string_of_prim_int (i:Uint63.int) : string := (* Better? DecimalString.NilZero.string_of_uint (BinNat.N.to_uint (BinInt.Z.to_N (Int63.to_Z i))). ? *) string_of_Z (Uint63.to_Z i). @@ -20,7 +20,7 @@ Definition string_of_float (f : PrimFloat.float) : string := | S754_infinity sign => if sign then "-INFINITY" else "INFINITY" | S754_nan => "NAN" | S754_finite sign p z => - let abs := "0x" ++ bytestring.String.of_string (Numbers.HexadecimalString.NilZero.string_of_uint (Pos.to_hex_uint p)) ++ "p" ++ + let abs := "0x" ++ bytestring.String.of_string (Numbers.HexadecimalString.NilZero.string_of_uint (Pos.to_hex_uint p)) ++ "p" ++ bytestring.String.of_string (Numbers.DecimalString.NilZero.string_of_int (Z.to_int z)) in if sign then "-" ++ abs else abs end. \ No newline at end of file diff --git a/template-coq/theories/TemplateCheckWf.v b/template-coq/theories/TemplateCheckWf.v index 0d6a9f1e9..54de0453e 100644 --- a/template-coq/theories/TemplateCheckWf.v +++ b/template-coq/theories/TemplateCheckWf.v @@ -7,14 +7,14 @@ Open Scope bs_scope. #[local] Existing Instance config.default_checker_flags. -Definition eta_expand p := +Definition eta_expand p := EtaExpand.eta_expand_program p. Definition check_def (d : kername × global_decl) : TemplateMonad unit := match d.2 with | ConstantDecl cb => match cb.(cst_body) with - | Some body => + | Some body => tmMsg ("Unquoting eta-expanded " ++ string_of_kername d.1)%bs ;; tmUnquote body ;; tmMsg ("Succeeded") @@ -51,7 +51,7 @@ Fixpoint wfterm (t : term) : bool := From Coq Require Import ssrbool. -Definition wf_global_decl d := +Definition wf_global_decl d := match d with | ConstantDecl cb => wfterm cb.(cst_type) && option_default wfterm cb.(cst_body) true | InductiveDecl idecl => true @@ -61,15 +61,15 @@ Definition wf_global_env (g : global_env) := wf_global_declarations g.(declarati Definition wf_program p := wf_global_env p.1 && wfterm p.2. Definition check_wf (g : Ast.Env.program) : TemplateMonad unit := - monad_map check_def g.1.(declarations) ;; + monad_map check_def g.1.(declarations) ;; tmMsg "Wellformed global environment" ;; ret tt. - + Axiom assume_wt_template_program : forall p : Ast.Env.program, ∥ wt_template_program p ∥. Definition check_wf_eta (p : Ast.Env.program) : TemplateMonad unit := - monad_map check_def (eta_expand (make_template_program_env p (assume_wt_template_program p))).1.(declarations) ;; + monad_map check_def (eta_expand (make_template_program_env p (assume_wt_template_program p))).1.(declarations) ;; tmMsg "Wellformed eta-expanded global environment" ;; ret tt. -(* To test that a program's eta-expansion is indeed well-typed according to Coq's kernel use: - +(* To test that a program's eta-expansion is indeed well-typed according to Coq's kernel use: + MetaCoq Run (tmQuoteRec wf_program >>= check_wf_eta). *) diff --git a/template-coq/theories/TemplateEnvMap.v b/template-coq/theories/TemplateEnvMap.v index b448cdf30..2ee0cf5c6 100644 --- a/template-coq/theories/TemplateEnvMap.v +++ b/template-coq/theories/TemplateEnvMap.v @@ -15,8 +15,8 @@ Qed. Local Coercion declarations : global_env >-> global_declarations. Module GlobalEnvMap. - Record t := - { env :> global_env; + Record t := + { env :> global_env; map : EnvMap.t global_decl; repr : EnvMap.repr env.(declarations) map; wf : EnvMap.fresh_globals env.(declarations) }. @@ -24,13 +24,13 @@ Module GlobalEnvMap. Definition lookup_env Σ kn := EnvMap.lookup kn Σ.(map). Lemma lookup_env_spec (Σ : t) kn : lookup_env Σ kn = Env.lookup_env Σ kn. - Proof. + Proof. rewrite /lookup_env /Env.lookup_env. apply (EnvMap.lookup_spec Σ.(env).(declarations)); apply Σ. Qed. Definition lookup_minductive Σ kn : option mutual_inductive_body := - decl <- lookup_env Σ kn;; + decl <- lookup_env Σ kn;; match decl with | ConstantDecl _ => None | InductiveDecl mdecl => ret mdecl @@ -46,7 +46,7 @@ Module GlobalEnvMap. mdecl <- lookup_minductive Σ (inductive_mind kn) ;; idecl <- nth_error mdecl.(ind_bodies) (inductive_ind kn) ;; ret (mdecl, idecl). - + Lemma lookup_inductive_spec Σ kn : lookup_inductive Σ kn = Ast.lookup_inductive Σ kn. Proof. rewrite /lookup_inductive /Ast.lookup_inductive. @@ -56,7 +56,7 @@ Module GlobalEnvMap. Definition lookup_constructor Σ kn c : option (mutual_inductive_body * one_inductive_body * constructor_body) := '(mdecl, idecl) <- lookup_inductive Σ kn ;; cdecl <- nth_error idecl.(ind_ctors) c ;; - ret (mdecl, idecl, cdecl). + ret (mdecl, idecl, cdecl). Lemma lookup_constructor_spec Σ kn : lookup_constructor Σ kn = Ast.lookup_constructor Σ kn. Proof. diff --git a/template-coq/theories/TemplateMonad/Common.v b/template-coq/theories/TemplateMonad/Common.v index e404e941a..13268f42d 100644 --- a/template-coq/theories/TemplateMonad/Common.v +++ b/template-coq/theories/TemplateMonad/Common.v @@ -5,7 +5,7 @@ Local Set Universe Polymorphism. (** Reduction strategy to apply, beware [cbv], [cbn] and [lazy] are _strong_. *) - + Monomorphic Variant reductionStrategy : Set := cbv | cbn | hnf | all | lazy | unfold (i : kername). diff --git a/template-coq/theories/TermEquality.v b/template-coq/theories/TermEquality.v index 958478b62..af8565b1e 100644 --- a/template-coq/theories/TermEquality.v +++ b/template-coq/theories/TermEquality.v @@ -12,7 +12,7 @@ Definition R_universe_instance R := (** Cumulative inductive types: - To simplify the development, we allow the variance list to not exactly + To simplify the development, we allow the variance list to not exactly match the instances, so as to keep syntactic equality an equivalence relation even on ill-formed terms. It corresponds to the right notion on well-formed terms. *) @@ -28,7 +28,7 @@ Fixpoint R_universe_instance_variance Re Rle v u u' := match u, u' return Prop with | u :: us, u' :: us' => match v with - | [] => R_universe_instance_variance Re Rle v us us' + | [] => R_universe_instance_variance Re Rle v us us' (* Missing variance stands for irrelevance, we still check that the instances have the same length. *) | v :: vs => R_universe_variance Re Rle v u u' /\ @@ -46,7 +46,7 @@ Definition lookup_minductive Σ mind := Definition lookup_inductive Σ ind := match lookup_minductive Σ (inductive_mind ind) with - | Some mdecl => + | Some mdecl => match nth_error mdecl.(ind_bodies) (inductive_ind ind) with | Some idecl => Some (mdecl, idecl) | None => None @@ -56,7 +56,7 @@ Definition lookup_inductive Σ ind := Definition lookup_constructor Σ ind k := match lookup_inductive Σ ind with - | Some (mdecl, idecl) => + | Some (mdecl, idecl) => match nth_error idecl.(ind_ctors) k with | Some cdecl => Some (mdecl, idecl, cdecl) | None => None @@ -68,7 +68,7 @@ Definition global_variance Σ gr napp := match gr with | IndRef ind => match lookup_inductive Σ ind with - | Some (mdecl, idecl) => + | Some (mdecl, idecl) => match destArity [] idecl.(ind_type) with | Some (ctx, _) => if (context_assumptions ctx) <=? napp then mdecl.(ind_variance) else None @@ -80,7 +80,7 @@ Definition global_variance Σ gr napp := match lookup_constructor Σ ind k with | Some (mdecl, idecl, cdecl) => if (cdecl.(cstr_arity) + mdecl.(ind_npars))%nat <=? napp then - (** Fully applied constructors are always compared at the same supertype, + (** Fully applied constructors are always compared at the same supertype, which implies that no universe equality needs to be checked here. *) Some [] else None @@ -90,7 +90,7 @@ Definition global_variance Σ gr napp := end. Definition R_opt_variance Re Rle v := - match v with + match v with | Some v => R_universe_instance_variance Re Rle v | None => R_universe_instance Re end. @@ -114,15 +114,15 @@ Qed. Inductive compare_decls (eq_term leq_term : term -> term -> Type) : context_decl -> context_decl -> Type := | compare_vass na T na' T' : eq_binder_annot na na' -> - leq_term T T' -> + leq_term T T' -> compare_decls eq_term leq_term (vass na T) (vass na' T') - | compare_vdef na b T na' b' T' : eq_binder_annot na na' -> + | compare_vdef na b T na' b' T' : eq_binder_annot na na' -> eq_term b b' -> leq_term T T' -> compare_decls eq_term leq_term (vdef na b T) (vdef na' b' T'). Derive Signature NoConfusion for compare_decls. -Lemma alpha_eq_context_assumptions {Γ Δ} : +Lemma alpha_eq_context_assumptions {Γ Δ} : All2 (compare_decls eq eq) Γ Δ -> context_assumptions Γ = context_assumptions Δ. Proof. @@ -130,7 +130,7 @@ Proof. destruct r; subst; cbn; auto. Qed. -Lemma alpha_eq_extended_subst {Γ Δ k} : +Lemma alpha_eq_extended_subst {Γ Δ k} : All2 (compare_decls eq eq) Γ Δ -> extended_subst Γ k = extended_subst Δ k. Proof. @@ -139,20 +139,20 @@ Proof. rewrite IHX. now rewrite (alpha_eq_context_assumptions X). Qed. -Lemma expand_lets_eq {Γ Δ t} : +Lemma expand_lets_eq {Γ Δ t} : All2 (compare_decls eq eq) Γ Δ -> expand_lets Γ t = expand_lets Δ t. Proof. intros. rewrite /expand_lets /expand_lets_k. - now rewrite (All2_length X) (alpha_eq_context_assumptions X) (alpha_eq_extended_subst X). + now rewrite (All2_length X) (alpha_eq_context_assumptions X) (alpha_eq_extended_subst X). Qed. -Lemma alpha_eq_subst_context {Γ Δ s k} : +Lemma alpha_eq_subst_context {Γ Δ s k} : All2 (compare_decls eq eq) Γ Δ -> All2 (compare_decls eq eq) (subst_context s k Γ) (subst_context s k Δ). Proof. intros. - rewrite /subst_context. + rewrite /subst_context. induction X. - cbn; auto. - rewrite !fold_context_k_snoc0. constructor; auto. @@ -165,7 +165,7 @@ Qed. (** Equality is indexed by a natural number that counts the number of applications that surround the current term, used to implement cumulativity of inductive types - correctly (only fully applied constructors and inductives benefit from it). *) + correctly (only fully applied constructors and inductives benefit from it). *) Inductive eq_term_upto_univ_napp Σ (Re Rle : Universe.t -> Universe.t -> Prop) (napp : nat) : term -> term -> Type := | eq_Rel n : @@ -251,7 +251,7 @@ Inductive eq_term_upto_univ_napp Σ (Re Rle : Universe.t -> Universe.t -> Prop) eq_binder_annot x.(dname) y.(dname) ) mfix mfix' -> eq_term_upto_univ_napp Σ Re Rle napp (tCoFix mfix idx) (tCoFix mfix' idx) - + | eq_Cast t1 c t2 t1' c' t2' : eq_term_upto_univ_napp Σ Re Re 0 t1 t1' -> eq_cast_kind c c' -> @@ -271,7 +271,7 @@ Definition compare_term `{checker_flags} (pb : conv_pb) Σ φ := Notation eq_term := (compare_term Conv). Notation leq_term := (compare_term Cumul). -Lemma R_global_instance_refl Σ Re Rle gr napp u : +Lemma R_global_instance_refl Σ Re Rle gr napp u : RelationClasses.Reflexive Re -> RelationClasses.Reflexive Rle -> R_global_instance Σ Re Rle gr napp u u. @@ -288,12 +288,12 @@ Qed. #[global] Instance eq_binder_annot_equiv {A} : RelationClasses.Equivalence (@eq_binder_annot A A). Proof. - split. + split. - red. reflexivity. - red; now symmetry. - intros x y z; unfold eq_binder_annot. congruence. -Qed. +Qed. Definition eq_binder_annot_refl {A} x : @eq_binder_annot A A x x. Proof. reflexivity. Qed. @@ -302,11 +302,11 @@ Proof. reflexivity. Qed. #[global] Instance eq_binder_annots_refl {A} : CRelationClasses.Equivalence (All2 (@eq_binder_annot A A)). Proof. split. - intros x. apply All2_reflexivity; tc. + intros x. apply All2_reflexivity; tc. * intros l. reflexivity. * intros l l' H. eapply All2_symmetry => //. * intros l l' H. eapply All2_transitivity => //. - intros ? ? ? ? ?. now etransitivity. + intros ? ? ? ? ?. now etransitivity. Qed. Lemma eq_term_upto_univ_refl Σ Re Rle : @@ -328,7 +328,7 @@ Proof. - destruct X as [Ppars Preturn]. eapply All_All2. 1:eassumption. intros; easy. - destruct X as [Ppars Preturn]. now apply Preturn. - - red in X0. eapply All_All2_refl. solve_all. reflexivity. + - red in X0. eapply All_All2_refl. solve_all. reflexivity. - eapply All_All2. 1: eassumption. intros x [? ?]. repeat split ; auto. - eapply All_All2. 1: eassumption. @@ -349,7 +349,7 @@ Proof. - intro; apply eq_universe_refl. - intro; apply leq_universe_refl. Qed. -(* +(* Lemma eq_term_leq_term `{checker_flags} Σ φ napp t u : eq_term_upto_univ_napp Σ napp φ t u -> leq_term Σ φ t u. Proof. @@ -421,7 +421,7 @@ Proof. Qed. -Lemma global_variance_napp_mon {Σ gr napp napp' v} : +Lemma global_variance_napp_mon {Σ gr napp napp' v} : napp <= napp' -> global_variance Σ gr napp = Some v -> global_variance Σ gr napp' = Some v. diff --git a/template-coq/theories/Transform.v b/template-coq/theories/Transform.v index 0620d6672..d8a6dc55c 100644 --- a/template-coq/theories/Transform.v +++ b/template-coq/theories/Transform.v @@ -1,6 +1,6 @@ (* Distributed under the terms of the MIT license. *) -(** Generic transofmations from one language to another, +(** Generic transofmations from one language to another, preserving an evaluation relation up-to some observational equality. *) From Coq Require Import Program ssreflect ssrbool. @@ -11,11 +11,11 @@ Local Open Scope bs. Local Open Scope string_scope2. (* Used to show timings of the ML execution *) - + Definition time : forall {A B}, string -> (A -> B) -> A -> B := fun A B s f x => f x. -Extract Constant time => +Extract Constant time => "(fun c f x -> let s = Caml_bytestring.caml_string_of_bytestring c in Tm_util.time (Pp.str s) f x)". Module Transform. @@ -24,23 +24,23 @@ Module Transform. Context {value value' : Type}. Context {eval : program -> value -> Prop}. Context {eval' : program' -> value' -> Prop}. - + Definition preserves_eval pre (transform : forall p : program, pre p -> program') obseq := forall p v (pr : pre p), eval p v -> let p' := transform p pr in exists v', eval' p' v' /\ obseq p p' v v'. - Record t := - { name : string; - pre : program -> Prop; + Record t := + { name : string; + pre : program -> Prop; transform : forall p : program, pre p -> program'; post : program' -> Prop; correctness : forall input (p : pre input), post (transform input p); obseq : program -> program' -> value -> value' -> Prop; preservation : preserves_eval pre transform obseq; }. - Definition run (x : t) (p : program) (pr : pre x p) : program' := + Definition run (x : t) (p : program) (pr : pre x p) : program' := time x.(name) (fun _ => x.(transform) p pr) tt. End Opt. @@ -54,11 +54,11 @@ Module Transform. Context {eval : program -> value -> Prop}. Context {eval' : program' -> value' -> Prop}. Context {eval'' : program'' -> value'' -> Prop}. - + Local Obligation Tactic := idtac. - Program Definition compose (o : t program program' value value' eval eval') (o' : t program' program'' value' value'' eval' eval'') + Program Definition compose (o : t program program' value value' eval eval') (o' : t program' program'' value' value'' eval' eval'') (hpp : (forall p, o.(post) p -> o'.(pre) p)) : t program program'' value value'' eval eval'' := - {| + {| name := (o.(name) ^ " -> " ^ o'.(name))%bs; transform p hp := run o' (run o p hp) (hpp _ (o.(correctness) _ hp)); pre := o.(pre); diff --git a/template-coq/theories/Typing.v b/template-coq/theories/Typing.v index a8baea065..3814bee72 100644 --- a/template-coq/theories/Typing.v +++ b/template-coq/theories/Typing.v @@ -97,10 +97,10 @@ Definition iota_red npar args bctx br := Inductive instantiate_params_subst_spec : context -> list term -> list term -> term -> list term -> term -> Prop := | instantiate_params_subst_nil s ty : instantiate_params_subst_spec [] [] s ty s ty -| instantiate_params_subst_vass na ty params pari pars s na' ty' pty s' pty' : +| instantiate_params_subst_vass na ty params pari pars s na' ty' pty s' pty' : instantiate_params_subst_spec params pars (pari :: s) pty s' pty' -> instantiate_params_subst_spec (vass na ty :: params) (pari :: pars) s (tProd na' ty' pty) s' pty' -| instantiate_params_subst_vdef na b ty params pars s na' b' ty' pty s' pty' : +| instantiate_params_subst_vdef na b ty params pars s na' b' ty' pty s' pty' : instantiate_params_subst_spec params pars (subst s 0 b :: s) pty s' pty' -> instantiate_params_subst_spec (vdef na b ty :: params) pars s (tLetIn na' b' ty' pty) s' pty'. Derive Signature for instantiate_params_subst_spec. @@ -130,7 +130,7 @@ Fixpoint instantiate_params_subst end end. -Lemma instantiate_params_substP params pars s ty s' ty' : +Lemma instantiate_params_substP params pars s ty s' ty' : instantiate_params_subst params pars s ty = Some (s', ty') <-> instantiate_params_subst_spec params pars s ty s' ty'. Proof. @@ -178,8 +178,8 @@ Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := (** Case *) | red_iota ci mdecl idecl cdecl c u args p brs br : nth_error brs c = Some br -> - (* In the compact representation, reduction must fetch the - global declaration of the constructor to gather the let-bindings + (* In the compact representation, reduction must fetch the + global declaration of the constructor to gather the let-bindings in its argument context. Implementations can be more clever in the common case where no let-binding appears to avoid this. *) declared_constructor Σ (ci.(ci_ind), c) mdecl idecl cdecl -> @@ -236,12 +236,12 @@ Inductive red1 (Σ : global_env) (Γ : context) : term -> term -> Type := red1 Σ (Γ ,,, case_predicate_context ind.(ci_ind) mdecl idecl p) preturn preturn' -> red1 Σ Γ (tCase ind p c brs) (tCase ind p' c brs) - + | case_red_discr ind p c c' brs : red1 Σ Γ c c' -> red1 Σ Γ (tCase ind p c brs) (tCase ind p c' brs) | case_red_brs ind mdecl idecl (isdecl : declared_inductive Σ ind.(ci_ind) mdecl idecl) p c brs brs' : - OnOne2All (fun brctx br br' => - on_Trel_eq (red1 Σ (Γ ,,, brctx)) bbody bcontext br br') + OnOne2All (fun brctx br br' => + on_Trel_eq (red1 Σ (Γ ,,, brctx)) bbody bcontext br br') (case_branches_contexts ind.(ci_ind) mdecl idecl p brs) brs brs' -> red1 Σ Γ (tCase ind p c brs) (tCase ind p c brs') @@ -292,7 +292,7 @@ Lemma red1_ind_all : declared_constructor Σ (ci.(ci_ind), c) mdecl idecl cdecl -> let bctx := case_branch_context ci.(ci_ind) mdecl cdecl p br in #|args| = (ci.(ci_npar) + context_assumptions bctx)%nat -> - P Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) + P Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs) (iota_red ci.(ci_npar) args bctx br)) -> (forall (Γ : context) (mfix : mfixpoint term) (idx : nat) (args : list term) (narg : nat) (fn : term), @@ -344,13 +344,13 @@ Lemma red1_ind_all : P (Γ ,,, case_predicate_context ci.(ci_ind) mdecl idecl p) preturn preturn' -> P Γ (tCase ci p c brs) (tCase ci (mk_predicate puinst params pcontext preturn') c brs)) -> - + (forall (Γ : context) (ind : case_info) (p : predicate term) (c c' : term) (brs : list (branch term)), red1 Σ Γ c c' -> P Γ c c' -> P Γ (tCase ind p c brs) (tCase ind p c' brs)) -> - (forall (Γ : context) ind mdecl idecl (isdecl : declared_inductive Σ ind.(ci_ind) mdecl idecl) p c brs brs', - OnOne2All (fun brctx br br' => - on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, brctx)) (P (Γ ,,, brctx))) bbody bcontext br br') + (forall (Γ : context) ind mdecl idecl (isdecl : declared_inductive Σ ind.(ci_ind) mdecl idecl) p c brs brs', + OnOne2All (fun brctx br br' => + on_Trel_eq (Trel_conj (red1 Σ (Γ ,,, brctx)) (P (Γ ,,, brctx))) bbody bcontext br br') (case_branches_contexts ind.(ci_ind) mdecl idecl p brs) brs brs' -> P Γ (tCase ind p c brs) (tCase ind p c brs')) -> @@ -407,14 +407,14 @@ Proof. match goal with | H : _ |- _ => eapply H; eauto; fail end]. - + - apply X13. revert params params' o. fix auxl 3. intros params params' []. + constructor. split; auto. + constructor. auto. - + - eapply X16; eauto. revert brs brs' o. intros brs. @@ -489,9 +489,9 @@ Reserved Notation " Σ ;;; Γ |- t <=[ pb ] u " (at level 50, Γ, t, u at next l (** ** Cumulativity: - Reduction to terms in the cumulativity relation. In PCUIC we show that + Reduction to terms in the cumulativity relation. In PCUIC we show that this is equivalent to the reflexive-transitive closure or reduction + leq_term - on well-typed terms. + on well-typed terms. *) Inductive cumul_gen `{checker_flags} (Σ : global_env_ext) (Γ : context) (pb : conv_pb) : term -> term -> Type := @@ -545,7 +545,7 @@ Module TemplateConversionPar <: ConversionParSig TemplateTerm Env TemplateTermUt End TemplateConversionPar. -Class GuardChecker := +Class GuardChecker := { (* Structural recursion check *) fix_guard : global_env_ext -> context -> mfixpoint term -> bool ; (* Guarded by destructors check *) @@ -555,7 +555,7 @@ Class GuardChecker := fix_guard Σ Γ mfix -> red1 Σ Γ (tFix mfix idx) (tFix mfix' idx) -> fix_guard Σ Γ mfix' ; - + fix_guard_lift Σ Γ Γ' Γ'' mfix : let k' := (#|mfix| + #|Γ'|)%nat in let mfix' := map (map_def (lift #|Γ''| #|Γ'|) (lift #|Γ''| k')) mfix in @@ -574,7 +574,7 @@ Class GuardChecker := fix_guard (Σ.1, univs) (subst_instance u Γ) (map (map_def (subst_instance u) (subst_instance u)) mfix) ; - fix_guard_extends Σ Γ mfix (Σ' : global_env_ext) : + fix_guard_extends Σ Γ mfix (Σ' : global_env_ext) : fix_guard Σ Γ mfix -> extends Σ.1 Σ' -> fix_guard Σ' Γ mfix ; @@ -601,8 +601,8 @@ Class GuardChecker := cofix_guard Σ Γ mfix -> cofix_guard (Σ.1, univs) (subst_instance u Γ) (map (map_def (subst_instance u) (subst_instance u)) mfix) ; - - cofix_guard_extends Σ Γ mfix (Σ' : global_env_ext) : + + cofix_guard_extends Σ Γ mfix (Σ' : global_env_ext) : cofix_guard Σ Γ mfix -> extends Σ.1 Σ' -> cofix_guard Σ' Γ mfix }. @@ -812,7 +812,7 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> let brctxty := case_branch_type ci.(ci_ind) mdecl p ptm i cdecl br in (wf_nactx br.(bcontext) (cstr_branch_context ci.(ci_ind) mdecl cdecl)) * (Σ ;;; Γ ,,, brctxty.1 |- br.(bbody) : brctxty.2) * - (Σ ;;; Γ ,,, brctxty.1 |- brctxty.2 : tSort ps)) + (Σ ;;; Γ ,,, brctxty.1 |- brctxty.2 : tSort ps)) 0 idecl.(ind_ctors) brs -> Σ ;;; Γ |- tCase ci p c brs : mkApps ptm (indices ++ [c]) @@ -840,20 +840,20 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> wf_cofixpoint Σ mfix -> Σ ;;; Γ |- tCoFix mfix n : decl.(dtype) -| type_Int p prim_ty cdecl : - wf_local Σ Γ -> +| type_Int p prim_ty cdecl : + wf_local Σ Γ -> primitive_constant Σ primInt = Some prim_ty -> declared_constant Σ prim_ty cdecl -> primitive_invariants cdecl -> Σ ;;; Γ |- tInt p : tConst prim_ty [] -| type_Float p prim_ty cdecl : - wf_local Σ Γ -> +| type_Float p prim_ty cdecl : + wf_local Σ Γ -> primitive_constant Σ primFloat = Some prim_ty -> declared_constant Σ prim_ty cdecl -> primitive_invariants cdecl -> Σ ;;; Γ |- tFloat p : tConst prim_ty [] - + | type_Conv t A B s : Σ ;;; Γ |- t : A -> Σ ;;; Γ |- B : tSort s -> @@ -940,7 +940,7 @@ Proof. fix typing_size 5. destruct 1 ; repeat match goal with - | H : typing _ _ _ _ |- _ => apply typing_size in H + | H : typing _ _ _ _ |- _ => apply typing_size in H end; match goal with | H : All2 _ _ _ |- _ => idtac @@ -981,7 +981,7 @@ Fixpoint globdecls_size (Σ : global_declarations) : size := | d :: Σ => S (globdecls_size Σ) end. -Definition globenv_size (Σ : global_env) : size := +Definition globenv_size (Σ : global_env) : size := globdecls_size Σ.(declarations). @@ -1011,7 +1011,7 @@ Defined. Lemma type_Prop_wf `{checker_flags} Σ Γ : wf_local Σ Γ -> Σ ;;; Γ |- tSort Universe.lProp : tSort Universe.type1. -Proof. +Proof. constructor;auto. constructor. Defined. @@ -1115,7 +1115,7 @@ Lemma typing_ind_env `{cf : checker_flags} : (Pdecl := fun Σ Γ wfΓ t T tyT => P Σ Γ t T) (PΓ : forall Σ Γ, wf_local Σ Γ -> Type), - (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ), + (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ), All_local_env_over typing Pdecl Σ Γ wfΓ -> PΓ Σ Γ wfΓ) -> (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) (n : nat) decl, @@ -1183,10 +1183,10 @@ Lemma typing_ind_env `{cf : checker_flags} : consistent_instance_ext Σ mdecl.(ind_universes) u -> P Σ Γ (tConstruct ind i u) (type_of_constructor mdecl cdecl (ind, i) u)) -> - (forall (Σ : global_env_ext) (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ), + (forall (Σ : global_env_ext) (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ), forall (ci : case_info) p c brs indices ps mdecl idecl (isdecl : declared_inductive Σ.1 ci.(ci_ind) mdecl idecl), - on_global_env cumul_gen (lift_typing P) Σ.1 -> + on_global_env cumul_gen (lift_typing P) Σ.1 -> PΓ Σ Γ wfΓ -> mdecl.(ind_npars) = ci.(ci_npar) -> wf_nactx p.(pcontext) (ind_predicate_context ci.(ci_ind) mdecl idecl) -> @@ -1194,7 +1194,7 @@ Lemma typing_ind_env `{cf : checker_flags} : consistent_instance_ext Σ (ind_universes mdecl) p.(puinst) -> let predctx := case_predicate_context ci.(ci_ind) mdecl idecl p in ctx_inst (Prop_conj typing P) Σ Γ (p.(pparams) ++ indices) - (List.rev (ind_params mdecl ,,, ind_indices idecl)@[p.(puinst)]) -> + (List.rev (ind_params mdecl ,,, ind_indices idecl)@[p.(puinst)]) -> forall pret : Σ ;;; Γ ,,, predctx |- p.(preturn) : tSort ps, P Σ (Γ ,,, predctx) p.(preturn) (tSort ps) -> PΓ Σ (Γ ,,, predctx) (typing_wf_local pret) -> @@ -1207,13 +1207,13 @@ Lemma typing_ind_env `{cf : checker_flags} : let brctxty := case_branch_type ci.(ci_ind) mdecl p ptm i cdecl br in wf_nactx br.(bcontext) (cstr_branch_context ci.(ci_ind) mdecl cdecl) * Prop_conj typing P Σ (Γ ,,, brctxty.1) br.(bbody) brctxty.2 * - Prop_conj typing P Σ (Γ ,,, brctxty.1) brctxty.2 (tSort ps)) + Prop_conj typing P Σ (Γ ,,, brctxty.1) brctxty.2 (tSort ps)) 0 idecl.(ind_ctors) brs -> P Σ Γ (tCase ci p c brs) (mkApps ptm (indices ++ [c]))) -> (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) (p : projection) (c : term) u mdecl idecl cdecl pdecl (isdecl : declared_projection Σ.1 p mdecl idecl cdecl pdecl) args, - on_global_env cumul_gen (lift_typing P) Σ.1 -> + on_global_env cumul_gen (lift_typing P) Σ.1 -> PΓ Σ Γ wfΓ -> Σ ;;; Γ |- c : mkApps (tInd p.(proj_ind) u) args -> P Σ Γ c (mkApps (tInd p.(proj_ind) u) args) -> @@ -1246,7 +1246,7 @@ Lemma typing_ind_env `{cf : checker_flags} : declared_constant Σ prim_ty cdecl -> primitive_invariants cdecl -> P Σ Γ (tInt p) (tConst prim_ty [])) -> - + (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) p prim_ty cdecl, PΓ Σ Γ wfΓ -> primitive_constant Σ primFloat = Some prim_ty -> @@ -1263,7 +1263,7 @@ Lemma typing_ind_env `{cf : checker_flags} : Σ ;;; Γ |- A <= B -> P Σ Γ t B) -> - env_prop P PΓ. + env_prop P PΓ. Proof. intros P Pdecl PΓ; unfold env_prop. intros XΓ. @@ -1289,7 +1289,7 @@ Proof. intros (Σ & wfΣ & Γ & t & t0 & H). simpl. intros IH. simpl in IH. split. - destruct Σ as [Σ φ]. + destruct Σ as [Σ φ]. red. cbn. do 2 red in wfΣ. cbn in wfΣ. destruct Σ as [univs Σ]; cbn in *. set (Σg:= {| universes := univs; declarations := Σ |}) in *. @@ -1298,8 +1298,8 @@ Proof. destruct o. { constructor. } rename o0 into Xg. set (wfΣ := (ongu, o) : on_global_env cumul_gen (lift_typing typing) {| universes := univs; declarations := Σ |}). set (Σ':= {| universes := univs; declarations := Σ |}) in *. - destruct Xg. rename udecl0 into udecl. - rename on_global_decl_d0 into Xg. + destruct Xg. rename udecl0 into udecl. + rename on_global_decl_d0 into Xg. constructor; auto; try constructor; auto. - unshelve eset (IH' := IH ((Σ', udecl); wfΣ; []; tSort Universe.lProp; _; _)). shelve. simpl. apply type_Prop. @@ -1381,7 +1381,7 @@ Proof. - simpl in *. apply IHfoo. lia. - red. apply (X14 _ _ _ t4). lia. - red. simpl. apply (X14 _ _ _ Hu). lia. } - + clear IH. assert (pΓ : PΓ Σ Γ (typing_wf_local H)). { apply (X13 _ _ _ H). lia. } @@ -1450,7 +1450,7 @@ Proof. * split; tas. eapply (IH _ _ _ t0); simpl; auto. lia. * eapply IHctxi. intros. eapply (IH _ _ _ Hty). simpl. lia. * eapply IHctxi. intros. eapply (IH _ _ _ Hty). simpl. lia. - + ++ simpl in X13. simpl in pΓ. auto. eapply (X14 _ _ _ H); eauto. simpl; auto with arith. ++ simpl in *. eapply (X13 _ _ _ H); eauto. simpl. subst predctx. lia. @@ -1574,7 +1574,7 @@ Proof. unfold on_global_env. destruct Σ as [univs Σ retro]; cbn. intros [cu ond]. induction ond; cbn in * => //. - destruct o. rename udecl0 into udecl. + destruct o. rename udecl0 into udecl. case: eqb_specT => [-> [= <-]| ne]. - exists ({| universes := univs; declarations := Σ; retroknowledge := retro |}, udecl). split; try constructor; tas. diff --git a/template-coq/theories/TypingWf.v b/template-coq/theories/TypingWf.v index af78b0bff..23f5bc4d8 100644 --- a/template-coq/theories/TypingWf.v +++ b/template-coq/theories/TypingWf.v @@ -88,7 +88,7 @@ Lemma on_global_env_impl `{checker_flags} Σ P Q : on_global_env cumul_gen P Σ -> on_global_env cumul_gen Q Σ. Proof. destruct Σ as [univs Σ]; cbn. - intros X [cu X0]; split => /= //. cbn in *. + intros X [cu X0]; split => /= //. cbn in *. induction X0; try destruct o; constructor; auto; constructor; eauto. clear IHX0. eapply on_global_decl_impl; tea. split => //. @@ -179,16 +179,16 @@ Hint Extern 10 => constructor : wf. #[global] Hint Resolve All_skipn : wf. -Lemma on_global_decls_extends_not_fresh {cf} {univs retro} k (Σ : global_declarations) k' (Σ' : global_declarations) P : +Lemma on_global_decls_extends_not_fresh {cf} {univs retro} k (Σ : global_declarations) k' (Σ' : global_declarations) P : on_global_decls cumul_gen P univs retro ((k :: Σ) ++ [k'] ++ Σ') -> k.1 = k'.1 -> False. Proof. intros H eq. - depelim H. destruct o as [f ? ? ?]. + depelim H. destruct o as [f ? ? ?]. eapply Forall_app in f as [_ f]. depelim f. cbn in *. subst. contradiction. Qed. -Lemma lookup_env_extends {cf : checker_flags} (Σ : global_env) k d (Σ' : global_env) P : +Lemma lookup_env_extends {cf : checker_flags} (Σ : global_env) k d (Σ' : global_env) P : on_global_env cumul_gen P Σ' -> lookup_env Σ k = Some d -> extends_decls Σ Σ' -> lookup_env Σ' k = Some d. @@ -202,7 +202,7 @@ Proof. subst univs. rewrite eq in wfΣ'. destruct Σ' as [univs' Σ']; cbn in *. subst Σ'. destruct wfΣ' as [cu wfΣ']. - induction Σ''. + induction Σ''. + cbn. now rewrite e eq_kername_refl. + cbn. destruct (eqb_spec k a0.1) => //. subst. { apply on_global_decls_extends_not_fresh in wfΣ'; eauto. } @@ -277,7 +277,7 @@ Qed. Lemma declared_inductive_wf_ctors {cf:checker_flags} {Σ} {ind} {mdecl idecl} : on_global_env cumul_gen wf_decl_pred Σ -> - declared_inductive Σ ind mdecl idecl -> + declared_inductive Σ ind mdecl idecl -> All (fun ctor => All (wf_decl Σ) ctor.(cstr_args)) (ind_ctors idecl). Proof. intros. @@ -297,7 +297,7 @@ Proof. destruct y => //. eapply IHargs; intuition eauto. Qed. -Lemma All_local_env_wf_decls Σ ctx : +Lemma All_local_env_wf_decls Σ ctx : TemplateEnvTyping.All_local_env (wf_decl_pred Σ) ctx -> All (wf_decl Σ) ctx. Proof. @@ -351,7 +351,7 @@ Proof. unfold build_case_predicate_context. unfold instantiate_params. destruct instantiate_params_subst as [[ictx p]|] eqn:ipars => /= //. - 2:{ split => //. intros H. depelim H. + 2:{ split => //. intros H. depelim H. eapply instantiate_params_substP in i. rewrite ipars in i. discriminate. } move: (destArity_spec [] (subst0 ictx p)). @@ -419,7 +419,7 @@ Section WfAst. apply IHipars; auto with wf. Qed. *) - Lemma wf_map2_set_binder_name l l' : + Lemma wf_map2_set_binder_name l l' : All (wf_decl Σ) l' -> All (wf_decl Σ) (map2 set_binder_name l l'). Proof using Type. @@ -446,7 +446,7 @@ Section WfAst. destruct p. destruct x as [? [] ?]; constructor; simpl in *; wf. Qed. - Lemma wf_subst_instance_context u Γ : + Lemma wf_subst_instance_context u Γ : All (wf_decl Σ) Γ -> All (wf_decl Σ) (subst_instance u Γ). Proof using Type. @@ -456,7 +456,7 @@ Section WfAst. destruct p. now split; auto; apply wf_subst_instance. Qed. - Lemma wf_extended_subst Γ n : + Lemma wf_extended_subst Γ n : All (wf_decl Σ) Γ -> All (WfAst.wf Σ) (extended_subst Γ n). Proof using Type. @@ -504,7 +504,7 @@ Section WfAst. Qed. (* Hint Resolve on_global_wf_Forall_decls : wf. *) - Lemma wf_inds mind u mdecl : + Lemma wf_inds mind u mdecl : All (WfAst.wf Σ) (inds mind u mdecl.(ind_bodies)). Proof using Type. unfold inds. induction #|ind_bodies mdecl|; constructor; auto. @@ -623,7 +623,7 @@ Section WfLookup. Proof using Type. unfold projs. induction p; constructor; wf. Qed. - + Lemma on_global_inductive_wf_bodies {kn mdecl} : on_global_decl cumul_gen wf_decl_pred Σ kn (InductiveDecl mdecl) -> All (wf_inductive_body Σ) mdecl.(ind_bodies). @@ -659,7 +659,7 @@ Section WfLookup. clear -onConstructors. induction onConstructors; constructor; auto. destruct r. - eapply on_ctype. + eapply on_ctype. - unfold on_constructors in onConstructors. clear -onConstructors. induction onConstructors; constructor; auto. @@ -675,13 +675,13 @@ Section WfLookup. destruct (ind_projs hd) eqn:eqprojs. constructor. forward on_projs by discriminate. destruct (ind_ctors hd) as [|? [|]] eqn:Heq; try contradiction. - destruct on_projs. rewrite eqprojs in on_projs. + destruct on_projs. rewrite eqprojs in on_projs. solve_all. eapply Alli_All; tea. intros. red in H. destruct (nth_error (smash_context _ _) _) eqn:Heq'; try contradiction. - simpl in Heq. inv wfargs. clear X0. + simpl in Heq. inv wfargs. clear X0. destruct H as [onna ->]. - eapply wf_subst. + eapply wf_subst. eapply wf_inds. eapply wf_subst. eapply wf_projs. eapply wf_lift. @@ -698,7 +698,7 @@ Lemma OnOne2All_All2_All2 (A B C : Type) (P : B -> A -> A -> Type) (Q : C -> A - (i : list B) (j : list C) (R : B -> Type) (l l' : list A) : OnOne2All P i l l' -> All2 Q j l -> - All R i -> + All R i -> (forall x y a b, R x -> P x a b -> Q y a -> Q y b) -> All2 Q j l'. Proof. @@ -774,7 +774,7 @@ Section WfRed. eapply OnOne2All_All2_All2; tea. cbn. intuition auto. now rewrite b0 in a1. apply b2 => //. - apply All_app_inv => //. + apply All_app_inv => //. - now eapply wf_mkApps. - constructor; auto. induction X; auto; congruence. clear H X0 H0. induction X; inv X1; constructor; intuition auto; try congruence. @@ -875,7 +875,7 @@ Section WfRed. Lemma wf_Lambda_or_LetIn {d t} : wf_decl Σ d -> - WfAst.wf Σ t -> + WfAst.wf Σ t -> WfAst.wf Σ (mkLambda_or_LetIn d t). Proof using Type. destruct d as [? [|] ?]; simpl; wf; @@ -886,7 +886,7 @@ Section WfRed. Lemma wf_it_mkLambda_or_LetIn {Γ t} : All (wf_decl Σ) Γ -> - WfAst.wf Σ t -> + WfAst.wf Σ t -> WfAst.wf Σ (it_mkLambda_or_LetIn Γ t). Proof using Type. intros wfΓ wft; induction wfΓ in t, wft |- *; simpl. @@ -918,14 +918,14 @@ Global Hint Rewrite cstr_branch_context_length : len. Section TypingWf. Context {cf}. - + Ltac specialize_goal := repeat match goal with | H : ?P -> _, H' : ?P |- _ => specialize (H H') end. Lemma typing_wf_gen : - env_prop + env_prop (fun Σ Γ t T => WfAst.wf Σ t * WfAst.wf Σ T) (fun Σ Γ wfΓ => All (wf_decl Σ) Γ). Proof using Type. @@ -939,7 +939,7 @@ Section TypingWf. apply (nth_error_all H X). - split. constructor; auto. wf. clear -X1. - induction X1; constructor; now auto. + induction X1; constructor; now auto. destruct X0 as [_ X0]. clear X H H0. induction X1; auto. apply IHX1. @@ -967,7 +967,7 @@ Section TypingWf. assert (All (wf_decl Σ) predctx). { now apply All_app in X4 as [? ?]. } split; [econstructor; simpl; eauto; solve_all|]. - eapply All2i_All2; tea; repeat intuition auto. + eapply All2i_All2; tea; repeat intuition auto. apply wf_mkApps. subst ptm. wf. apply wf_it_mkLambda_or_LetIn; auto. apply All_app_inv; auto. - split. wf. apply wf_subst. solve_all. constructor. wf. @@ -975,7 +975,7 @@ Section TypingWf. eapply declared_projection_wf in isdecl; eauto. now eapply wf_subst_instance. now eapply Forall_decls_on_global_wf. - + - subst types. clear H. split. @@ -983,14 +983,14 @@ Section TypingWf. solve_all; destruct a, b. all: intuition. + eapply All_nth_error in X0; eauto. - destruct X0 as [s ?]; intuition. + destruct X0 as [s ?]; intuition. - subst types. split. + constructor. solve_all; destruct a, b. all: intuition. - + eapply All_nth_error in X0; eauto. destruct X0 as [s ?]; intuition. + + eapply All_nth_error in X0; eauto. destruct X0 as [s ?]; intuition. Qed. Lemma typing_all_wf_decl Σ (wfΣ : wf Σ.1) Γ (wfΓ : wf_local Σ Γ) : @@ -1020,7 +1020,7 @@ Section TypingWf. declared_minductive Σ mind mdecl -> All (wf_decl Σ) (ind_params mdecl) * All (@wf_inductive_body Σ) (ind_bodies mdecl). - Proof using Type. + Proof using Type. intros declm. pose proof (typing_wf_gen (Env.empty_ext Σ) wfΣ _ localenv_nil _ _ (type_Prop _)) as [X _]. eapply Forall_decls_on_global_wf in X. @@ -1043,8 +1043,8 @@ Section TypingWf. destruct decli as [declm hi]. eapply nth_error_all in wfb; tea. apply wfb. Qed. - - Lemma declared_constructor_wf_case_branch_context + + Lemma declared_constructor_wf_case_branch_context {Σ} {wfΣ : wf Σ} {ind mdecl idecl cdecl p br} : declared_constructor Σ ind mdecl idecl cdecl -> All (WfAst.wf Σ) (pparams p) -> @@ -1071,7 +1071,7 @@ Section TypingWf. eexists _, _; split; auto. rewrite appt //. Qed. - Lemma decompose_app_mkApp f u : + Lemma decompose_app_mkApp f u : (decompose_app (mkApp f u)).2 <> []. Proof using Type. induction f; simpl; auto; try congruence. @@ -1079,7 +1079,7 @@ Section TypingWf. Qed. Lemma mkApps_tApp' f u f' u' : - ~~ isApp f' -> + ~~ isApp f' -> mkApp f u = tApp f' u' -> mkApps f [u] = mkApps f' u'. Proof using Type. intros. @@ -1097,7 +1097,7 @@ Section TypingWf. decompose_app x = decompose_app y -> x = y. Proof using Type. intros wfx; revert y. - induction wfx using term_wf_forall_list_ind; intros [] wfy; + induction wfx using term_wf_forall_list_ind; intros [] wfy; eapply wf_inv in wfy; simpl in wfy; simpl; intros [= ?]; try intuition congruence. Qed. @@ -1107,7 +1107,7 @@ Section TypingWf. induction t; simpl; try solve [eexists _, _; reflexivity]. Qed. - Lemma strip_casts_decompose_app Σ t : + Lemma strip_casts_decompose_app Σ t : WfAst.wf Σ t -> forall f l, decompose_app t = (f, l) -> strip_casts t = mkApps (strip_casts f) (map strip_casts l). @@ -1131,7 +1131,7 @@ Section TypingWf. destruct args, f; try discriminate; auto. Qed. - Lemma strip_casts_mkApps_napp_wf Σ f u : + Lemma strip_casts_mkApps_napp_wf Σ f u : ~~ isApp f -> WfAst.wf Σ f -> All (WfAst.wf Σ) u -> strip_casts (mkApps f u) = mkApps (strip_casts f) (map strip_casts u). Proof using Type. @@ -1144,7 +1144,7 @@ Section TypingWf. Lemma mkApp_mkApps f u : mkApp f u = mkApps f [u]. Proof using Type. reflexivity. Qed. - Lemma decompose_app_inv Σ f l hd args : + Lemma decompose_app_inv Σ f l hd args : WfAst.wf Σ f -> decompose_app (mkApps f l) = (hd, args) -> ∑ n, ~~ isApp hd /\ l = skipn n args /\ f = mkApps hd (firstn n args). @@ -1169,7 +1169,7 @@ Section TypingWf. split; auto. now eapply negbT. Qed. - Lemma eq_tip_skipn {A} (x : A) n l : [x] = skipn n l -> + Lemma eq_tip_skipn {A} (x : A) n l : [x] = skipn n l -> exists l', l = l' ++ [x] /\ n = #|l'|. Proof using Type. induction l in n |- *. rewrite skipn_nil //. @@ -1180,7 +1180,7 @@ Section TypingWf. exists (a :: l'); split; reflexivity. Qed. - Lemma strip_casts_mkApp_wf Σ f u : + Lemma strip_casts_mkApp_wf Σ f u : WfAst.wf Σ f -> WfAst.wf Σ u -> strip_casts (mkApp f u) = mkApp (strip_casts f) (strip_casts u). Proof using Type. @@ -1189,7 +1189,7 @@ Section TypingWf. destruct (mkApp_ex_wf Σ f u wfa) as [f' [args [eq isapp]]]. eapply (f_equal decompose_app) in eq. simpl in eq. epose proof (strip_casts_decompose_app Σ _ wfa _ _ eq). - rewrite H. + rewrite H. rewrite mkApp_mkApps in eq. destruct (decompose_app_inv Σ _ _ _ _ wf eq) as [n [ng [stripeq stripf]]]. apply eq_tip_skipn in stripeq. destruct stripeq as [l' [eqargs eqn]]. @@ -1199,7 +1199,7 @@ Section TypingWf. now rewrite mkApp_mkApps -mkApps_app map_app. Qed. - Lemma strip_casts_mkApps_wf Σ f u : + Lemma strip_casts_mkApps_wf Σ f u : WfAst.wf Σ f -> All (WfAst.wf Σ) u -> strip_casts (mkApps f u) = mkApps (strip_casts f) (map strip_casts u). Proof using Type. diff --git a/template-coq/theories/UnivSubst.v b/template-coq/theories/UnivSubst.v index 611cb4485..b4016c3d9 100644 --- a/template-coq/theories/UnivSubst.v +++ b/template-coq/theories/UnivSubst.v @@ -6,7 +6,7 @@ From MetaCoq Require Import utils Ast AstUtils Environment Induction. Substitution of universe levels for universe level variables, used to implement universe polymorphism. *) -Lemma subst_instance_cons {A} {ua : UnivSubst A} u x xs : +Lemma subst_instance_cons {A} {ua : UnivSubst A} u x xs : subst_instance u (x :: xs) = subst_instance u x :: subst_instance u xs. Proof. reflexivity. Qed. @@ -16,7 +16,7 @@ Proof. unfold subst_instance; cbn. induction c in k |- * using term_forall_list_ind; simpl; auto; rewrite ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, - ?map_predicate_map_predicate, ?map_predicate_subst_instance_predicate, + ?map_predicate_map_predicate, ?map_predicate_subst_instance_predicate, ?map_branch_map_branch; f_equal; eauto; solve_all; eauto. Qed. @@ -53,7 +53,7 @@ Lemma subst_instance_subst u c N k : Proof. unfold subst_instance; cbn. induction c in k |- * using term_forall_list_ind; simpl; auto; - rewrite ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, + rewrite ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length, ?map_predicate_map_predicate, ?map_branch_map_branch; simpl; try solve [f_equal; eauto; solve_all; eauto]. @@ -61,7 +61,7 @@ Proof. - elim (Nat.leb k n). rewrite nth_error_map. destruct (nth_error N (n - k)). simpl. apply subst_instance_lift. reflexivity. reflexivity. - + - rewrite subst_instance_mkApps. f_equal; auto. rewrite map_map_compose. solve_all. Qed. diff --git a/template-coq/theories/Universes.v b/template-coq/theories/Universes.v index 9375bc449..dbcd1548b 100644 --- a/template-coq/theories/Universes.v +++ b/template-coq/theories/Universes.v @@ -125,7 +125,7 @@ Module Level. | Level.Var n1, Level.Var n2 => ReflectEq.eqb n1 n2 | _, _ => false end. - + #[global, program] Instance reflect_level : ReflectEq Level.t := { eqb := eq_level }. @@ -139,7 +139,7 @@ Module Level. - destruct (ReflectEq.eqb_spec n n0) ; nodec. constructor. subst. reflexivity. Defined. - + Global Instance eqb_refl : @Reflexive Level.t eqb. Proof. intros x. apply ReflectEq.eqb_refl. diff --git a/template-coq/theories/WcbvEval.v b/template-coq/theories/WcbvEval.v index e0d3f0096..5b6b208b1 100644 --- a/template-coq/theories/WcbvEval.v +++ b/template-coq/theories/WcbvEval.v @@ -24,7 +24,7 @@ Local Ltac inv H := inversion H; subst. (** ** Big step version of weak cbv beta-zeta-iota-fix-delta reduction. *) -(** We use a different substitution function that requires no lifting as it assumes +(** We use a different substitution function that requires no lifting as it assumes we are substituting closed terms. *) Fixpoint csubst t k u := @@ -167,7 +167,7 @@ Definition cstr_arity mdecl cdecl := (mdecl.(ind_npars) + context_assumptions cdecl.(cstr_args))%nat. Section Wcbv. - + Context (Σ : global_env). (* The local context is fixed: we are only doing weak reductions *) @@ -210,7 +210,7 @@ Section Wcbv. nth_error args (proj.(proj_npars) + proj.(proj_arg)) = Some a -> eval a res -> eval (tProj proj discr) res - + (** Fix unfolding, with guard *) | eval_fix f mfix idx fixargsv args argsv narg fn res : ~~ isApp f -> @@ -246,10 +246,10 @@ Section Wcbv. eval (tProj p discr) res (** Constructor congruence: we do not allow over-applications *) - | eval_construct ind c u mdecl idecl cdecl f args args' : + | eval_construct ind c u mdecl idecl cdecl f args args' : declared_constructor Σ (ind, c) mdecl idecl cdecl -> ~~ isApp f -> args <> [] -> - eval f (tConstruct ind c u) -> + eval f (tConstruct ind c u) -> #|args| <= cstr_arity mdecl cdecl -> All2 eval args args' -> eval (mkApps f args) (mkApps (tConstruct ind c u) args') @@ -258,7 +258,7 @@ Section Wcbv. | eval_app_cong f f' a a' : ~~ isApp f -> a <> [] -> (* This ensures eval only applies to well-formed terms *) eval f f' -> - ~~ (isLambda f' || isFixApp f' || isArityHead f' || isConstructApp f') -> + ~~ (isLambda f' || isFixApp f' || isArityHead f' || isConstructApp f') -> All2 eval a a' -> eval (tApp f a) (mkApps f' a') @@ -283,8 +283,8 @@ Section Wcbv. eval (mkApps (csubst a' 0 b) l) res -> P (mkApps (csubst a' 0 b) l) res -> P (tApp f (a :: l)) res) -> (forall (na : aname) (b0 b0' t b1 res : term), - eval b0 b0' -> P b0 b0' -> - eval (csubst b0' 0 b1) res -> + eval b0 b0' -> P b0 b0' -> + eval (csubst b0' 0 b1) res -> P (csubst b0' 0 b1) res -> P (tLetIn na b0 t b1) res) -> (forall c (decl : constant_body) (body : term), declared_constant Σ c decl -> @@ -301,7 +301,7 @@ Section Wcbv. declared_constructor Σ (ci.(ci_ind), c) mdecl idecl cdecl -> let bctx := case_branch_context ci.(ci_ind) mdecl cdecl p br in #|args| = (ci.(ci_npar) + context_assumptions bctx)%nat -> - eval (iota_red npar args bctx br) res -> P (iota_red npar args bctx br) res -> + eval (iota_red npar args bctx br) res -> P (iota_red npar args bctx br) res -> P (tCase ci p discr brs) res) -> (forall proj (discr : term) (args : list term) (u : Instance.t) a mdecl idecl cdecl pdecl res, @@ -335,7 +335,7 @@ Section Wcbv. cunfold_fix mfix idx = Some (narg, fn) -> #|fixargsv ++ argsv| <= narg -> P (mkApps f args) (mkApps (tFix mfix idx) (fixargsv ++ argsv))) -> - (forall (ip : case_info) (mfix : mfixpoint term) (idx : nat) + (forall (ip : case_info) (mfix : mfixpoint term) (idx : nat) (p : predicate term) discr (args : list term) (narg : nat) (fn : term) (brs : list (branch term)) (res : term), cunfold_cofix mfix idx = Some (narg, fn) -> @@ -349,12 +349,12 @@ Section Wcbv. P discr (mkApps (tCoFix mfix idx) args) -> eval (tProj p (mkApps fn args)) res -> P (tProj p (mkApps fn args)) res -> P (tProj p discr) res) -> - + (forall ind c u mdecl idecl cdecl f args args', declared_constructor Σ (ind, c) mdecl idecl cdecl -> ~~ isApp f -> args <> [] -> - eval f (tConstruct ind c u) -> - P f (tConstruct ind c u) -> + eval f (tConstruct ind c u) -> + P f (tConstruct ind c u) -> #|args| <= cstr_arity mdecl cdecl -> All2 eval args args' -> All2 P args args' -> @@ -406,7 +406,7 @@ Section Wcbv. value_head nargs (tConstruct ind c u) | value_head_cofix mfix idx : value_head nargs (tCoFix mfix idx) | value_head_ind ind u : value_head nargs (tInd ind u) - | value_head_fix mfix idx rarg fn : + | value_head_fix mfix idx rarg fn : cunfold_fix mfix idx = Some (rarg, fn) -> nargs <= rarg -> value_head nargs (tFix mfix idx). @@ -452,10 +452,10 @@ Section Wcbv. intros. subst. - now eapply atom_mkApps in H. - intros * isapp appeq. move: (value_head_nApp X) => Ht. - right. + right. apply mkApps_eq_inj in appeq => //. intuition subst; auto => //. Qed. - + Lemma value_mkApps_values t l : value (mkApps t l) -> ~~ isApp t -> @@ -493,12 +493,12 @@ Section Wcbv. Proof using Type. induction 1; congruence. Qed. - + Lemma All2_nil_rev {A} {P} {l l' : list A} : All2 P l l' -> l' <> [] -> l <> []. Proof using Type. induction 1; congruence. Qed. - + Lemma eval_to_value e e' : eval e e' -> value e'. Proof using Type. intros eve. induction eve using eval_evals_ind; simpl; intros; auto using value. @@ -515,7 +515,7 @@ Section Wcbv. eapply value_app; auto. econstructor; tea. rewrite -(All2_length X) //. now eapply All2_nil. - + - eapply All2_right in X0. depelim IHeve. destruct t; simpl in * |- *; try congruence. @@ -547,7 +547,7 @@ Section Wcbv. - now constructor. - now eapply eval_atom. - now eapply eval_atom. - - now eapply eval_atom. + - now eapply eval_atom. Qed. Lemma value_final e : value e -> eval e e. @@ -581,7 +581,7 @@ Section Wcbv. depelim a. apply atom_mkApps in H1 as (-> & ?). cbn in *. reflexivity. - + - eapply atom_mkApps in Ha as [-> ato]. rewrite (IHeval ato). now depelim a. diff --git a/template-coq/theories/WfAst.v b/template-coq/theories/WfAst.v index 05aec3d71..01bcaed1f 100644 --- a/template-coq/theories/WfAst.v +++ b/template-coq/theories/WfAst.v @@ -13,10 +13,10 @@ Require Import ssreflect ssrbool. The invariants are: - Application nodes have always at least one argument, and they cannot be nested (keeping terms in "spine" representation). - - Each `Case` refers to a declared inductive in the environment, and - the predicate context and branches contexts have lengths that match + - Each `Case` refers to a declared inductive in the environment, and + the predicate context and branches contexts have lengths that match the inductive declaration. This eases the proof of translation to PCUIC, - in particular reduction on well-formed terms in Template translate to + in particular reduction on well-formed terms in Template translate to reductions in PCUIC, without further typing assumptions. *) @@ -45,11 +45,11 @@ Inductive wf {Σ} : term -> Type := #|pparams p| = context_assumptions (ind_params mdecl) -> All wf (pparams p) -> wf (preturn p) -> wf c -> - All2 (fun cdecl br => + All2 (fun cdecl br => wf_nactx br.(bcontext) (cstr_branch_context ci.(ci_ind) mdecl cdecl) × wf (bbody br)) idecl.(ind_ctors) brs -> wf (tCase ci p c brs) -| wf_tProj p t : +| wf_tProj p t : wf t -> wf (tProj p t) | wf_tFix mfix k : All (fun def => wf def.(dtype) × wf def.(dbody)) mfix -> @@ -75,16 +75,16 @@ Definition wf_Inv Σ (t : term) : Type := | tConst c _ => unit | tInd ind _ => unit | tConstruct ind k _ => unit - | tCase ci p c brs => - ∑ mdecl idecl, + | tCase ci p c brs => + ∑ mdecl idecl, [× declared_inductive Σ ci.(ci_ind) mdecl idecl, ci.(ci_npar) = mdecl.(ind_npars), wf_nactx p.(pcontext) (ind_predicate_context ci.(ci_ind) mdecl idecl), #|pparams p| = context_assumptions (ind_params mdecl), All (wf Σ) (pparams p), - wf Σ (preturn p), + wf Σ (preturn p), wf Σ c & - All2 (fun cdecl br => + All2 (fun cdecl br => wf_nactx br.(bcontext) (cstr_branch_context ci.(ci_ind) mdecl cdecl) × wf Σ (bbody br)) idecl.(ind_ctors) brs] | tProj p t => wf Σ t @@ -106,7 +106,7 @@ Proof. apply lift_to_list. now inversion_clear X. Defined. -Lemma lift_to_wf_list Σ (P : term -> Type) : forall l, All (fun t => wf Σ t -> P t) l -> +Lemma lift_to_wf_list Σ (P : term -> Type) : forall l, All (fun t => wf Σ t -> P t) l -> All (wf Σ) l -> All P l. Proof. induction 1. constructor. @@ -139,11 +139,11 @@ Lemma term_wf_forall_list_ind Σ : #|pparams p| = context_assumptions (ind_params mdecl) -> wf_nactx p.(pcontext) (ind_predicate_context ci.(ci_ind) mdecl idecl) -> tCasePredProp P P p -> forall t : term, P t -> forall l : list (branch term), - All2 (fun cdecl br => + All2 (fun cdecl br => wf_nactx br.(bcontext) (cstr_branch_context ci.(ci_ind) mdecl cdecl) × P (bbody br)) idecl.(ind_ctors) l -> P (tCase ci p t l)) -> - (forall (s : projection) (t : term), - + (forall (s : projection) (t : term), + P t -> P (tProj s t)) -> (forall (m : mfixpoint term) (n : nat), tFixProp P P m -> P (tFix m n)) -> (forall (m : mfixpoint term) (n : nat), tFixProp P P m -> P (tCoFix m n)) -> diff --git a/template-coq/theories/common/uGraph.v b/template-coq/theories/common/uGraph.v index 49326d738..9ff5c68f9 100644 --- a/template-coq/theories/common/uGraph.v +++ b/template-coq/theories/common/uGraph.v @@ -99,12 +99,12 @@ Module VariableLevel. destruct (compare_spec y z); auto; try congruence. destruct (compare_spec x z); auto; try congruence. subst. elimtype False. eapply irreflexivity. etransitivity; [exact H|exact H0]. - elimtype False. eapply irreflexivity. etransitivity; [exact H|]. + elimtype False. eapply irreflexivity. etransitivity; [exact H|]. eapply transitivity; [exact H0|exact H1]. destruct (compare_spec y z); auto; try congruence. destruct (compare_spec x z); auto; try congruence. subst. elimtype False. eapply irreflexivity. etransitivity; [exact H|exact H0]. - elimtype False. eapply irreflexivity. etransitivity; [exact H|]. + elimtype False. eapply irreflexivity. etransitivity; [exact H|]. eapply transitivity; [exact H1|exact H0]. Qed. @@ -145,7 +145,7 @@ Module GoodConstraint. Definition eq_refl := @eq_refl t. Definition eq_sym := @eq_sym t. Definition eq_trans := @eq_trans t. - + Definition eq_equiv : RelationClasses.Equivalence eq := _. Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. unfold eq. @@ -157,7 +157,7 @@ Module GoodConstraint. Definition compare (x : t) (y : t) : comparison := match x, y with - | gc_le u n v, gc_le u' n' v' => + | gc_le u n v, gc_le u' n' v' => compare_cont (VariableLevel.compare u u') (compare_cont (Z.compare n n') (VariableLevel.compare v v')) | _, gc_le _ _ _ => Datatypes.Lt | gc_le _ _ _, _ => Gt @@ -181,17 +181,17 @@ Module GoodConstraint. Lemma compare_sym (a b : t): compare b a = CompOpp (compare a b). Proof. - revert b. destruct a, b; try easy; cbn; + revert b. destruct a, b; try easy; cbn; rewrite !compare_cont_CompOpp -?VariableLevel.compare_sym ?Zcompare_antisym -?PeanoNat.Nat.compare_antisym -?StringOT.compare_sym //. Qed. - - + + Lemma nat_compare_trans : forall c (x y z : nat), (x?=y)%nat = c -> (y?=z)%nat = c -> (x?=z)%nat = c. Proof. intros c x y z. destruct (Nat.compare_spec x y); subst => // <-; - destruct (Nat.compare_spec y z); subst => //; + destruct (Nat.compare_spec y z); subst => //; destruct (Nat.compare_spec x z); subst => //; try lia. Qed. @@ -199,23 +199,23 @@ Module GoodConstraint. Proof. intros c x y z. destruct (Z.compare_spec x y); subst => // <-; - destruct (Z.compare_spec y z); subst => //; + destruct (Z.compare_spec y z); subst => //; destruct (Z.compare_spec x z); subst => //; try lia. Qed. - + Lemma nat_compare_eq : forall (x y : nat), (x?=y)%nat = Datatypes.Eq -> x = y. Proof. intros x y. destruct (Nat.compare_spec x y) => //. Qed. - + Lemma compare_trans : forall c (x y z : t), (x?=y) = c -> (y?=z) = c -> (x?=z) = c. Proof. intros c x y z. destruct x, y, z; cbn; try repeat apply compare_cont_trans; eauto using VariableLevel.compare_trans, VariableLevel.compare_eq; try congruence. all:eauto using StringOT.compare_trans, nat_compare_trans, nat_compare_eq. - intros. eapply compare_cont_trans; tea; + intros. eapply compare_cont_trans; tea; eauto using VariableLevel.compare_trans, VariableLevel.compare_eq, Z.compare_eq, Z_compare_trans. Qed. @@ -262,7 +262,7 @@ Module GoodConstraint. Proof. intros x y ? ? ? ?. now rewrite H H0. Qed. - + Lemma compare_spec : forall x y : t, CompSpec eq lt x y (compare x y). Proof. intros x y. @@ -363,11 +363,11 @@ Section GcOfConstraint. let pair := fun x y => Some (GoodConstraintSet_pair x y) in match uc with (* Set _ _ *) - | (Level.lzero, Le z, r) => + | (Level.lzero, Le z, r) => match Z.compare z 0 with | Datatypes.Eq => empty | Datatypes.Lt => (* Set <= l + n *) empty - | Datatypes.Gt => (* Set + n <= l *) + | Datatypes.Gt => (* Set + n <= l *) match r with | Level.lzero => None | Level.Level s => singleton (gc_lt_set_level (Z.to_nat (z - 1)) s) @@ -379,11 +379,11 @@ Section GcOfConstraint. | (Level.lzero, Eq, Level.Var n) => singleton (gc_le_var_set n 0%nat) (* Level _ _ *) - | (Level.Level l, Le z, Level.lzero) => + | (Level.Level l, Le z, Level.lzero) => (* l - n <= Set <-> l <= Set + n *) if (z <=? 0)%Z then singleton (gc_le_level_set l (Z.to_nat (Z.abs z))) else None - + | (Level.Level l, Le z, Level.Level l') => singleton (gc_le (Level l) z (Level l')) | (Level.Level l, Le z, Level.Var n) => singleton (gc_le (Level l) z (Var n)) @@ -394,7 +394,7 @@ Section GcOfConstraint. => pair (gc_le (Level l) 0 (Var n)) (gc_le (Var n) 0 (Level l)) (* Var _ _ *) - | (Level.Var n, Le z, Level.lzero) => + | (Level.Var n, Le z, Level.lzero) => (* l - n <= Set <-> l <= Set + n *) if (z <=? 0)%Z then singleton (gc_le_var_set n (Z.to_nat (Z.abs z))) else None @@ -426,7 +426,7 @@ Proof using Type. - unfold gc_satisfies. intros gc. eapply GoodConstraintSet.for_all_spec in gc; auto. 2:proper. - specialize (gc c). + specialize (gc c). rewrite -> GoodConstraintSet.singleton_spec in gc. now apply gc. Qed. @@ -455,11 +455,11 @@ Proof using Type. all: rewrite -> ?if_true_false in *; cbn -[GoodConstraintSet_pair] in *; try contradiction; repeat toProp; try lia. all:try (destruct (Z.compare_spec z 0); simpl in H; auto; try lia; - apply gc_satisfies_singleton in H; simpl in H; + apply gc_satisfies_singleton in H; simpl in H; (apply Nat.ltb_lt in H || apply Nat.leb_le in H); try lia). all:try (destruct (Z.leb_spec z 0); simpl in H; auto; try lia; - apply gc_satisfies_singleton in H; simpl in H; + apply gc_satisfies_singleton in H; simpl in H; (apply Nat.ltb_lt in H || apply Nat.leb_le in H); try lia). all:(try apply gc_satisfies_singleton in H; cbn in H; try toProp H); try lia. @@ -771,9 +771,9 @@ Proof. destruct l, ct, l'; cbn in HH; destruct prop_sub_type; cbn in HH. change VSet.In with LevelSet.In. all:repeat match goal with - | HH : context [ (?z ?= 0)%Z ] |- _ => + | HH : context [ (?z ?= 0)%Z ] |- _ => destruct (Z.compare_spec z 0); simpl in HH; auto - | HH : context [ (?z <=? 0)%Z ] |- _ => + | HH : context [ (?z <=? 0)%Z ] |- _ => destruct (Z.leb_spec z 0); simpl in HH; auto | HH : False |- _ => contradiction HH | HH : GoodConstraintSet.In ?A GoodConstraintSet.empty |- _ @@ -801,7 +801,7 @@ Definition EdgeSet_triple x y z Definition edge_of_constraint (gc : GoodConstraint.t) : EdgeSet.elt := match gc with | GoodConstraint.gc_le l z l' => (vtn l, z, vtn l') - | GoodConstraint.gc_lt_set_level k s => (lzero, Z.of_nat (S k), vtn (VariableLevel.Level s)) + | GoodConstraint.gc_lt_set_level k s => (lzero, Z.of_nat (S k), vtn (VariableLevel.Level s)) | GoodConstraint.gc_le_set_var k n => (lzero, Z.of_nat k, vtn (VariableLevel.Var n)) | GoodConstraint.gc_le_level_set s k => (vtn (VariableLevel.Level s), (- Z.of_nat k)%Z, lzero) | GoodConstraint.gc_le_var_set n k => (vtn (VariableLevel.Var n), (- Z.of_nat k)%Z, lzero) @@ -838,15 +838,15 @@ Definition add_level_edges := | Some ll => EdgeSet.add (edge_of_level ll) E end). -Definition add_cstrs ctrs := +Definition add_cstrs ctrs := GoodConstraintSet.fold (fun ctr => EdgeSet.add (edge_of_constraint ctr)) ctrs. -Lemma add_cstrs_spec e x g : +Lemma add_cstrs_spec e x g : EdgeSet.In e (add_cstrs x g) <-> (exists c, edge_of_constraint c = e /\ GoodConstraintSet.In c x) \/ EdgeSet.In e g. Proof. rewrite /add_cstrs GoodConstraintSet.fold_spec. - transitivity + transitivity ((exists c, edge_of_constraint c = e /\ In c (GoodConstraintSet.elements x)) \/ EdgeSet.In e g). - induction (GoodConstraintSet.elements x) in g |- *; simpl. intuition auto. now destruct H0 as [c [_ F]]. @@ -959,12 +959,12 @@ Proof. assert (He: EdgeSet.In (edge_of_level (VariableLevel.Level s)) (wGraph.E (make_graph uctx))). { apply make_graph_E. left. exists (VariableLevel.Level s). intuition. } unshelve eexists _. - econstructor. 2: constructor. + econstructor. 2: constructor. eexists; exact He. simpl. sq; lia. assert (He: EdgeSet.In (edge_of_level (VariableLevel.Var n)) (wGraph.E (make_graph uctx))). { apply make_graph_E. left. exists (VariableLevel.Var n). intuition. } unshelve eexists _. - econstructor. 2: constructor. + econstructor. 2: constructor. eexists; exact He. simpl. sq; auto. lia. Qed. @@ -1129,7 +1129,7 @@ Proof. symmetry; apply (make_graph_spec2 (uctx.1, ctrs)); tas. Qed. -Definition Equal_graph := +Definition Equal_graph := fun G G' : universes_graph => LevelSet.Equal G.1.1 G'.1.1 /\ wGraph.EdgeSet.Equal G.1.2 G'.1.2 /\ Level.eq G.2 G'.2. @@ -1205,7 +1205,7 @@ Section CheckLeq. | inr _ => True end. - + Definition gc_level_declared l := VSet.In l uctx.1. @@ -1245,7 +1245,7 @@ Section CheckLeq. val v (LevelAlgExpr.make (l, n)) = n + labelling_of_valuation v l. Proof using Type. - reflexivity. + reflexivity. Qed. Lemma val_valuation_of_labelling' L (l : Level.t) n @@ -1296,7 +1296,7 @@ Section CheckLeq. intros H. unfold_univ_rel0. apply make_graph_spec in Hv; tas. eapply correct_labelling_proper in Hv; tea. 2:reflexivity. - red in Hv. + red in Hv. specialize (H _ Hv). rewrite !val_labelling_of_valuation; lia. Qed. @@ -1330,7 +1330,7 @@ Section CheckLeq. Definition leqb_level_n n (l l' : Level.t) := leqb_vertices G n l l'. - + Lemma leqb_level_n_spec0 n l l' : leqb_level_n n l l' -> gc_leq0_levelalg_n n uctx.2 (LevelAlgExpr.make' l) (LevelAlgExpr.make' l'). @@ -1350,13 +1350,13 @@ Section CheckLeq. etransitivity. apply leqb_vertices_correct; try exact _. 1-2:now rewrite HG; exact _. now unfold leqb_level_n. Qed. - + (* this is function [check_smaller_expr] of kernel/uGraph.ml *) Definition leqb_expr_n lt (e1 e2 : LevelExpr.t) := match e1, e2 with | (l1, k), (l2, k') => (* l1 + k < n = l2 + k' <-> l1 < n + (k - k') = l2 *) - leqb_level_n (lt + (Z.of_nat k - Z.of_nat k')) l1 l2 + leqb_level_n (lt + (Z.of_nat k - Z.of_nat k')) l1 l2 end. Lemma leqb_expr_n_spec0 lt e e' @@ -1390,7 +1390,7 @@ Section CheckLeq. specialize (H v Hv). simpl in H. cbn in H. lia. Qed. - + Import NonEmptySetFacts. (* this is function [exists_bigger] of kernel/uGraph.ml *) @@ -1452,7 +1452,7 @@ Section CheckLeq. Lemma Z_of_nat_inj_bool (x : bool) : Z.of_nat (if x then 1%nat else 0%nat) = ⎩ x ⎭. Proof using Type. destruct x; simpl; auto. Qed. - Definition neg_forall p u := + Definition neg_forall p u := LevelExprSet.for_all p u = false. Lemma exists_neg_forall p u : neg_forall p u <-> LevelExprSet.exists_ (fun x => ~~ (p x)) u. @@ -1465,17 +1465,17 @@ Section CheckLeq. eapply LevelExprSet.for_all_spec in HH. 2:proper. red in ex. eapply LevelExprSet.exists_spec in ex as [x [inx npx]]. 2:proper. - specialize (HH _ inx). simpl in HH. rewrite HH in npx. simpl in npx. congruence. + specialize (HH _ inx). simpl in HH. rewrite HH in npx. simpl in npx. congruence. Qed. Definition lsp_expr G l (ei : LevelExpr.t) : Nbar.t := let '(li, bi) := ei in (lsp G l li + Some (Z.of_nat bi))%nbar. - + Local Open Scope Z_scope. Definition is_lt (x y : Nbar.t) : bool := ~~ le_lt_dec y x. - + Lemma is_lt_spec x y : is_lt x y -> (x < y)%nbar. Proof using Type. unfold is_lt. destruct le_lt_dec. simpl. discriminate. simpl. @@ -1559,10 +1559,10 @@ Section CheckLeq. rewrite !Nat2Z.inj_add in H. rewrite Z_of_nat_inj_bool in H. assert (Z.of_nat (lab l) = - lset). - { unfold lab. + { unfold lab. epose proof (Subgraph1.lsp_G'_spec_left G _ _ Hinl Vs _ Hlset l). fold G' in H1. rewrite Hs H1. clear H1. - rewrite lsp_xx. + rewrite lsp_xx. pose proof (lsp_sym _ Hlset). destruct (lsp_s G l Hinl) as [sl' [lspsl' w]]. rewrite Hs in lspsl'. rewrite lspsl' in H1 |- *. @@ -1681,7 +1681,7 @@ Section CheckLeq. assert (Hs' : VSet.In lzero (wGraph.V G)). { rewrite <- Hs; apply HG1. } set (G' := wGraph.G' G lzero l K) in *. - assert (lsG : l <> wGraph.s G). intros eq. + assert (lsG : l <> wGraph.s G). intros eq. { rewrite eq in HlSet, Hnl. congruence. } assert (HG'1 : invariants G'). { @@ -1751,7 +1751,7 @@ Section CheckLeq. assert (lab li = to_label (Some ni)) as XX'. { subst lab; cbn. subst G'. rewrite -> Hs in *. rewrite lsp_G'_spec_left; tas. now rewrite Hki Hni. } - rewrite XX' in H. + rewrite XX' in H. rewrite !Nat2Z.inj_add !Z_of_to_label Z_of_nat_inj_bool in H. destruct (Z.leb_spec 0 K); [|lia]. destruct (Z.leb_spec 0 ni); [|lia]. @@ -1995,16 +1995,16 @@ Section CheckLeq. Definition gc_leq_universe := leq_universe_n_ (fun n φ u u' => if check_univs then gc_leq0_levelalg_n n φ u u' else True) 0. - + Definition gc_eq_universe := eq_universe_ (fun φ u u' => if check_univs then gc_eq0_levelalg φ u u' else True). - + Let levels_declared_univ (u : Universe.t) := match u with | Universe.lSProp | Universe.lProp => True | Universe.lType l => gc_levels_declared l end. - + Lemma check_eqb_universe_spec (u1 u2 : Universe.t) (Hu1 : levels_declared_univ u1) (Hu2 : levels_declared_univ u2) @@ -2157,7 +2157,7 @@ Section CheckLeq2. apply <- check_leqb_levelalg_spec; eauto. exact eq. Qed. - + Lemma check_eqb_levelalg_spec' u1 u2 : check_eqb_levelalg G u1 u2 -> eq_levelalg uctx.2 u1 u2. Proof using HG' Huctx'. @@ -2174,7 +2174,7 @@ Section CheckLeq2. split; eapply gc_leq0_levelalg_iff; (destruct (gc_of_constraints uctx.2); [cbn in *|contradiction HG]); tas. Qed. - + Lemma check_eqb_levelalg_complete u1 u2 : levels_declared u1 -> levels_declared u2 -> @@ -2206,7 +2206,7 @@ Section CheckLeq2. Definition valid_gc_constraints (gcs : GoodConstraintSet.t) := GoodConstraintSet.For_all valid_gc_constraint gcs. - + Lemma leq0_level_n_complete z l l' : level_declared l -> level_declared l' -> @@ -2223,16 +2223,16 @@ Section CheckLeq2. Definition gc_levels_declared' (vset : VSet.t) gc := match gc with - | GoodConstraint.gc_le l _ l' => VSet.In (VariableLevel.to_noprop l) vset /\ + | GoodConstraint.gc_le l _ l' => VSet.In (VariableLevel.to_noprop l) vset /\ VSet.In (VariableLevel.to_noprop l') vset | GoodConstraint.gc_lt_set_level _ n | GoodConstraint.gc_le_level_set n _ => VSet.In (Level.Level n) vset | GoodConstraint.gc_le_set_var _ n | GoodConstraint.gc_le_var_set n _ => VSet.In (Level.Var n) vset end. - + Definition gcs_levels_declared (vset : VSet.t) gcs := GoodConstraintSet.For_all (gc_levels_declared' vset) gcs. - + Lemma check_gc_constraint_complete cstr : gc_levels_declared' uctx.1 cstr -> valid_gc_constraint cstr -> @@ -2270,11 +2270,11 @@ Section CheckLeq2. destruct v; cbn in *; red; intros v Hv'; specialize (Hv _ Hv'); eapply GoodConstraintSetFact.for_all_iff in Hv; try typeclasses eauto; - specialize (Hv _ inv); cbn in Hv; cbn; + specialize (Hv _ inv); cbn in Hv; cbn; rewrite ?val_level_of_variable_level //. now eapply Z.leb_le in Hv. - eapply Nat.leb_le in Hv. lia. + eapply Nat.leb_le in Hv. lia. apply Nat.leb_le in Hv. lia. apply Nat.leb_le in Hv. lia. apply Nat.leb_le in Hv. lia. @@ -2312,7 +2312,7 @@ Section CheckLeq2. epose proof (check_gc_constraints_spec _ uctx' Huctx' HC' HG' _ HH). destruct check_univs => //=. intros v Hv. - cbn. + cbn. apply gc_of_constraints_spec. apply gc_of_constraints_spec in Hv. rewrite Hctrs'; cbn. eapply H. @@ -2325,7 +2325,7 @@ Section CheckLeq2. Lemma check_constraints_complete ctrs : check_univs -> global_uctx_invariants (uctx.1, ctrs) -> - valid_constraints uctx.2 ctrs -> + valid_constraints uctx.2 ctrs -> check_constraints G ctrs. Proof using HG' Huctx'. intros cu gu vc. @@ -2379,7 +2379,7 @@ Section CheckLeq2. unfold check_leqb_universe. toProp; right. apply check_leqb_levelalg_complete => //. Qed. - + Lemma check_eqb_universe_spec' u1 u2 : check_eqb_universe G u1 u2 -> eq_universe uctx.2 u1 u2. Proof using HG' Huctx'. @@ -2397,7 +2397,7 @@ Section CheckLeq2. apply NonEmptySetFacts.univ_expr_eqb_true_iff in HH as ->. toProp; left; toProp; right; now apply NonEmptySetFacts.univ_expr_eqb_true_iff. Qed. - + Lemma check_eqb_universe_complete u1 u2 : levels_declared_univ u1 -> levels_declared_univ u2 -> @@ -2428,11 +2428,11 @@ Section AddLevelsCstrs. Definition uctx_of_udecl u : ContextSet.t := (levels_of_udecl u, constraints_of_udecl u). - Lemma gcs_elements_union s s' : GoodConstraintSet.Empty s' -> + Lemma gcs_elements_union s s' : GoodConstraintSet.Empty s' -> GoodConstraintSet.Equal (GoodConstraintSet.union s s') s. Proof. gcsets. Qed. - Lemma add_level_edges_spec e x g : + Lemma add_level_edges_spec e x g : EdgeSet.In e (add_level_edges x g) <-> (exists c, option_edge_of_level c = Some e /\ VSet.In c x) \/ EdgeSet.In e g. Proof. @@ -2455,7 +2455,7 @@ Section AddLevelsCstrs. destruct a; simpl; rewrite -> ?EdgeSet.add_spec; simpl; intuition auto. Qed. - Lemma add_cstrs_union g ctrs1 ctrs2 : + Lemma add_cstrs_union g ctrs1 ctrs2 : EdgeSet.Equal (add_cstrs (GoodConstraintSet.union ctrs1 ctrs2) g) (add_cstrs ctrs1 (add_cstrs ctrs2 g)). Proof. intros e. @@ -2474,7 +2474,7 @@ Section AddLevelsCstrs. firstorder eauto. Qed. - Lemma add_level_edges_add_cstrs_comm l c g : + Lemma add_level_edges_add_cstrs_comm l c g : EdgeSet.Equal (add_level_edges l (add_cstrs c g)) (add_cstrs c (add_level_edges l g)). Proof. @@ -2484,7 +2484,7 @@ Section AddLevelsCstrs. Qed. Lemma forallb_spec {A : Type} (p : A -> bool) (l : list A) : - match forallb p l with + match forallb p l with | true => forall x : A, In x l -> p x | false => exists x : A, In x l × p x = false end. @@ -2514,22 +2514,22 @@ Section AddLevelsCstrs. specialize (H0 x (proj2 (heq _) hin)). congruence. Qed. - Lemma levelset_for_all_eq f f' l l' : - (forall x, f x = f' x) -> LevelSet.Equal l l' -> + Lemma levelset_for_all_eq f f' l l' : + (forall x, f x = f' x) -> LevelSet.Equal l l' -> LevelSet.for_all f l = LevelSet.for_all f' l'. Proof. intros Hf heq. rewrite !VSetFact.for_all_b. setoid_replace f with f'; auto. - eapply forallb_in. + eapply forallb_in. intros x. red in heq. specialize (heq x). rewrite -!InA_In_eq. now rewrite -!LevelSetFact.elements_iff. Qed. - - Lemma Nbar_max_spec n m v : + + Lemma Nbar_max_spec n m v : Nbar.max n m = v -> (Nbar.le n m /\ v = m) \/ (Nbar.le m n /\ v = n). Proof. @@ -2539,13 +2539,13 @@ Section AddLevelsCstrs. right. split; auto. congruence. Qed. - Lemma Nbar_max_spec' n m : + Lemma Nbar_max_spec' n m : Nbar.le n m -> Nbar.max m n = m. Proof. destruct n, m; cbn; firstorder. f_equal. lia. Qed. - Lemma Nbar_max_spec'' n m : + Lemma Nbar_max_spec'' n m : Nbar.le n m -> Nbar.max n m = m. Proof. destruct n, m; cbn; firstorder. f_equal. lia. @@ -2560,7 +2560,7 @@ Section AddLevelsCstrs. - now transitivity n. Qed. - Lemma fold_left_max_spec (l : list Nbar.t) acc n : + Lemma fold_left_max_spec (l : list Nbar.t) acc n : fold_left Nbar.max l acc = n -> (n = acc /\ (forall x, In x l -> Nbar.le x n)) \/ (In n l /\ Nbar.le acc n /\ (forall x, In x l -> Nbar.le x n)). @@ -2580,7 +2580,7 @@ Section AddLevelsCstrs. Qed. - Lemma fold_left_max_spec' (l : list Nbar.t) acc n : + Lemma fold_left_max_spec' (l : list Nbar.t) acc n : (n = acc /\ (forall x, In x l -> Nbar.le x n)) \/ (In n l /\ Nbar.le acc n /\ (forall x, In x l -> Nbar.le x n)) -> fold_left Nbar.max l acc = n. @@ -2598,7 +2598,7 @@ Section AddLevelsCstrs. apply Nbar.max_lub; auto. Qed. - Lemma fold_left_comm_ext (l l' : list Nbar.t) : + Lemma fold_left_comm_ext (l l' : list Nbar.t) : (forall x, In x l <-> In x l') -> fold_left Nbar.max l =1 fold_left Nbar.max l'. Proof. @@ -2616,7 +2616,7 @@ Section AddLevelsCstrs. intuition auto. now apply eql. now apply H3, eql. Qed. - Lemma fold_left_comm_ext2 f f' (l l' : list (Z × Level.t)) : f =1 f' -> + Lemma fold_left_comm_ext2 f f' (l l' : list (Z × Level.t)) : f =1 f' -> (forall x, In x l <-> In x l') -> fold_left Nbar.max (map f l) =1 fold_left Nbar.max (map f' l'). Proof. @@ -2627,8 +2627,8 @@ Section AddLevelsCstrs. specialize (eqg x0). exists x0; intuition auto. now rewrite -eqf. exists x0. specialize (eqg x0). rewrite eqf; intuition auto. Qed. - - Lemma Equal_graph_edges {e e'} : Equal_graph e e' -> + + Lemma Equal_graph_edges {e e'} : Equal_graph e e' -> forall x, In x (EdgeSet.elements e.1.2) <-> In x (EdgeSet.elements e'.1.2). Proof. intros [vs [es ?]]. intros x. red in vs. @@ -2643,10 +2643,10 @@ Section AddLevelsCstrs. setoid_rewrite filter_In. now setoid_rewrite (Equal_graph_edges eq). Qed. - - Lemma fold_left_comm_ext3 f f' e e' x : f =1 f' -> + + Lemma fold_left_comm_ext3 f f' e e' x : f =1 f' -> Equal_graph e e' -> - fold_left Nbar.max (map f (succs e x)) =1 + fold_left Nbar.max (map f (succs e x)) =1 fold_left Nbar.max (map f' (succs e' x)). Proof. intros eqf eqg. @@ -2666,12 +2666,12 @@ Section AddLevelsCstrs. revert H. generalize e.1.1, e'.1.1. intros t0 t1. induction (LevelSet.cardinal t0) in t0, t1, e, e', He, x, y |- *. cbn; auto. - cbn. intros eqt. + cbn. intros eqt. replace (LevelSet.mem x t0) with (LevelSet.mem x t1). 2:{ now rewrite eqt. } destruct LevelSet.mem; auto. apply fold_left_comm_ext3; auto. - intros [n0 y0]. f_equal. + intros [n0 y0]. f_equal. apply (IHn e e' He). intros elt. rewrite !LevelSet.remove_spec. intuition auto. now apply eqt. now apply eqt. @@ -2686,7 +2686,7 @@ Section AddLevelsCstrs. apply eq. Qed. - Lemma add_uctx_make_graph levels1 levels2 ctrs1 ctrs2 : + Lemma add_uctx_make_graph levels1 levels2 ctrs1 ctrs2 : Equal_graph (add_uctx (levels1, ctrs1) (make_graph (levels2, ctrs2))) (make_graph (VSet.union levels1 levels2, GoodConstraintSet.union ctrs1 ctrs2)). @@ -2721,7 +2721,7 @@ Section AddLevelsCstrs. Lemma add_gc_of_constraint_spec {cf:checker_flags} gc t : match add_gc_of_constraint gc (Some t) with - | Some t' => + | Some t' => exists gcs, gc_of_constraint gc = Some gcs /\ GCS.Equal t' (GCS.union t gcs) | None => gc_of_constraint gc = None @@ -2751,11 +2751,11 @@ Section AddLevelsCstrs. now rewrite fold_left_add_gc_None. Qed. - Variant gc_of_constraints_view {cf:checker_flags} (s : ConstraintSet.t) : option GoodConstraintSet.t -> Type := - | gc_of_constraints_ok l : - (forall gc, GoodConstraintSet.In gc l <-> + Variant gc_of_constraints_view {cf:checker_flags} (s : ConstraintSet.t) : option GoodConstraintSet.t -> Type := + | gc_of_constraints_ok l : + (forall gc, GoodConstraintSet.In gc l <-> (exists c gcs, gc_of_constraint c = Some gcs /\ ConstraintSet.In c s /\ GoodConstraintSet.In gc gcs)) -> - (forall c, ConstraintSet.In c s -> + (forall c, ConstraintSet.In c s -> exists gcs, gc_of_constraint c = Some gcs /\ GoodConstraintSet.Subset gcs l) -> gc_of_constraints_view s (Some l) | gc_of_constraints_none : diff --git a/template-coq/theories/monad_utils.v b/template-coq/theories/monad_utils.v index d1a952ae5..458597a22 100644 --- a/template-coq/theories/monad_utils.v +++ b/template-coq/theories/monad_utils.v @@ -51,7 +51,7 @@ Import MCMonadNotation. | None => None end |}. - + #[global] Instance option_monad_exc : MonadExc unit option := {| raise T _ := None ; catch T m f := @@ -102,14 +102,14 @@ Section MonadOperations. | y :: l => x' <- g x y ;; monad_fold_left l x' end. - + Fixpoint monad_fold_right (l : list B) (x : A) : T A := match l with | nil => ret x | y :: l => l' <- monad_fold_right l x ;; g l' y end. - + Context (h : nat -> A -> T B). Fixpoint monad_map_i_aux (n0 : nat) (l : list A) : T (list B) := match l with @@ -128,7 +128,7 @@ Section MonadOperations. Fixpoint monad_map2 (l : list A) (l' : list B) : T (list C) := match l, l' with | nil, nil => ret nil - | x :: l, y :: l' => + | x :: l, y :: l' => x' <- f x y ;; xs' <- monad_map2 l l' ;; ret (x' :: xs') @@ -147,7 +147,7 @@ Fixpoint monad_All {T : Type -> Type} {M : Monad T} {A} {P} (f : forall x, T (P end. Fixpoint monad_All2 {T : Type -> Type} {E} {M : Monad T} {M' : MonadExc E T} wrong_sizes - {A B R} (f : forall x y, T (R x y)) l1 l2 : T (@All2 A B R l1 l2) := + {A B R} (f : forall x y, T (R x y)) l1 l2 : T (@All2 A B R l1 l2) := match l1, l2 with | [], [] => ret All2_nil | a :: l1, b :: l2 => X <- f a b ;; @@ -158,7 +158,7 @@ Fixpoint monad_All2 {T : Type -> Type} {E} {M : Monad T} {M' : MonadExc E T} wro Definition monad_prod {T} {M : Monad T} {A B} (x : T A) (y : T B): T (A * B)%type := X <- x ;; Y <- y ;; ret (X, Y). - + (** monadic checks *) Definition check_dec {T : Type -> Type} {E : Type} {M : Monad T} {M' : MonadExc E T} (e : E) {P} (H : {P} + {~ P}) : T P @@ -167,7 +167,7 @@ Definition check_dec {T : Type -> Type} {E : Type} {M : Monad T} {M' : MonadExc | right _ => raise e end. -Definition check_eq_true {T : Type -> Type} {E : Type} {M : Monad T} {M' : MonadExc E T} (b : bool) (e : E) : T b := +Definition check_eq_true {T : Type -> Type} {E : Type} {M : Monad T} {M' : MonadExc E T} (b : bool) (e : E) : T b := if b return T b then ret eq_refl else raise e. Definition check_eq_nat {T : Type -> Type} {E : Type} {M : Monad T} {M' : MonadExc E T} n m (e : E) : T (n = m) := @@ -209,7 +209,7 @@ Defined. Section monad_Alli_nth. Context {T} {M : Monad T} {A} {P : nat -> A -> Type}. Program Fixpoint monad_Alli_nth_gen l k - (f : forall n x, nth_error l n = Some x -> T (∥ P (k + n) x ∥)) : + (f : forall n x, nth_error l n = Some x -> T (∥ P (k + n) x ∥)) : T (∥ @Alli A P k l ∥) := match l with | [] => ret (sq Alli_nil) @@ -231,10 +231,10 @@ End monad_Alli_nth. Section MonadAllAll. Context {T : Type -> Type} {M : Monad T} {A} {P : A -> Type} {Q} (f : forall x, ∥ Q x ∥ -> T (∥ P x ∥)). - Program Fixpoint monad_All_All l : ∥ All Q l ∥ -> T (∥ All P l ∥) := + Program Fixpoint monad_All_All l : ∥ All Q l ∥ -> T (∥ All P l ∥) := match l return ∥ All Q l ∥ -> T (∥ All P l ∥) with | [] => fun _ => ret (sq All_nil) - | a :: l => fun allq => + | a :: l => fun allq => X <- f a _ ;; Y <- monad_All_All l _ ;; ret _ diff --git a/template-coq/theories/utils/All_Forall.v b/template-coq/theories/utils/All_Forall.v index a6a09502b..affca675b 100644 --- a/template-coq/theories/utils/All_Forall.v +++ b/template-coq/theories/utils/All_Forall.v @@ -84,7 +84,7 @@ Proof. now apply alli_ext. Qed. -Lemma alli_impl {A} (p q : nat -> A -> bool) n (l : list A) : +Lemma alli_impl {A} (p q : nat -> A -> bool) n (l : list A) : (forall i x, p i x -> q i x) -> alli p n l -> alli q n l. Proof. @@ -95,19 +95,19 @@ Proof. Qed. Lemma allbiP {A} (P : nat -> A -> Type) (p : nat -> A -> bool) n l : - (forall i x, reflectT (P i x) (p i x)) -> + (forall i x, reflectT (P i x) (p i x)) -> reflectT (Alli P n l) (alli p n l). Proof. intros Hp. apply equiv_reflectT. - induction 1; rewrite /= // IHX // andb_true_r. now destruct (Hp n hd). - - induction l in n |- *; rewrite /= //. constructor. + - induction l in n |- *; rewrite /= //. constructor. move/andb_and => [pa pl]. constructor; auto. now destruct (Hp n a). Qed. -Lemma alli_Alli {A} (p : nat -> A -> bool) n l : +Lemma alli_Alli {A} (p : nat -> A -> bool) n l : alli p n l <~> Alli p n l. Proof. destruct (allbiP p p n l). @@ -128,7 +128,7 @@ Qed. Section alli. Context {A} (p q : nat -> A -> bool) (l l' : list A). - Lemma alli_app n : + Lemma alli_app n : alli p n (l ++ l') = alli p n l && alli p (#|l| + n) l'. Proof using Type. @@ -152,7 +152,7 @@ Section alli. Qed. End alli. -Lemma alli_mapi {A B} (f : nat -> A -> bool) (g : nat -> B -> A) n l : +Lemma alli_mapi {A B} (f : nat -> A -> bool) (g : nat -> B -> A) n l : alli f n (mapi_rec g l n) = alli (fun i x => f i (g i x)) n l. Proof. revert n; induction l => n; simpl; auto. @@ -220,7 +220,7 @@ Proof. Qed. Lemma forallbP {A} (P : A -> Prop) (p : A -> bool) l : - (forall x, reflect (P x) (p x)) -> + (forall x, reflect (P x) (p x)) -> reflect (Forall P l) (forallb p l). Proof. intros Hp. @@ -244,7 +244,7 @@ Proof. intros f g Hfg ? ? ->. now apply forallb_ext. Qed. -Lemma forallbP_cond {A} (P Q : A -> Prop) (p : A -> bool) l : +Lemma forallbP_cond {A} (P Q : A -> Prop) (p : A -> bool) l : Forall Q l -> (forall x, Q x -> reflect (P x) (p x)) -> reflect (Forall P l) (forallb p l). Proof. @@ -259,7 +259,7 @@ Qed. Lemma nth_error_forallb {A} {p : A -> bool} {l : list A} {n x} : nth_error l n = Some x -> forallb p l -> p x. Proof. - intros Hnth HPl. + intros Hnth HPl. induction l in n, Hnth, HPl |- * => //. - rewrite nth_error_nil in Hnth => //. - destruct n => /=; noconf Hnth. @@ -356,7 +356,7 @@ Lemma All2_map_equiv {A B C D} {R : C -> D -> Type} {f : A -> C} {g : B -> D} {l Proof. split. - induction 1; simpl; constructor; try congruence. - - induction l in l' |- *; destruct l'; intros H; depelim H; constructor; auto. + - induction l in l' |- *; destruct l'; intros H; depelim H; constructor; auto. Qed. Lemma All2_map {A B C D} {R : C -> D -> Type} {f : A -> C} {g : B -> D} {l l'} : @@ -521,11 +521,11 @@ Proof. intros hp x. eapply All2_refl. intros; reflexivity. Qed. -Lemma All2_symmetry {A} (R : A -> A -> Type) : +Lemma All2_symmetry {A} (R : A -> A -> Type) : CRelationClasses.Symmetric R -> CRelationClasses.Symmetric (All2 R). Proof. - intros HR x y l. + intros HR x y l. induction l; constructor; auto. Qed. @@ -538,19 +538,19 @@ Proof. Qed. Lemma All2_apply {A B C} {D : A -> B -> C -> Type} {l : list B} {l' : list C} : - forall (a : A), + forall (a : A), All2 (fun x y => forall a : A, D a x y) l l' -> All2 (fun x y => D a x y) l l'. Proof. intros a all. eapply (All2_impl all); auto. -Qed. +Qed. Lemma All2_apply_arrow {A B C} {D : B -> C -> Type} {l : list B} {l' : list C} : A -> All2 (fun x y => A -> D x y) l l' -> All2 (fun x y => D x y) l l'. Proof. intros a all. eapply (All2_impl all); auto. -Qed. +Qed. Lemma All2_apply_dep_arrow {B C} {A} {D : B -> C -> Type} {l : list B} {l' : list C} : All A l -> @@ -560,7 +560,7 @@ Proof. intros a all. eapply All2_All_mix_left in all; tea. eapply (All2_impl all); intuition auto. -Qed. +Qed. Lemma All2_apply_dep_All {B C} {A} {D : C -> Type} {l : list B} {l' : list C} : All A l -> @@ -571,7 +571,7 @@ Proof. eapply All2_All_mix_left in all; tea. eapply All2_impl in all. 2:{ intros x y [ha hd]. exact (hd ha). } eapply All2_All_right; tea. auto. -Qed. +Qed. Lemma All2i_All_left {A B} {P : nat -> A -> B -> Type} {Q : A -> Type} {n l l'} : @@ -625,7 +625,7 @@ Proof. induction 1; constructor; auto. Qed. Lemma All_map_inv {A B} (P : B -> Type) (f : A -> B) l : All P (map f l) -> All (fun x => P (f x)) l. Proof. induction l; intros Hf; inv Hf; try constructor; eauto. Qed. -Lemma In_All {A} {P : A -> Type} l : +Lemma In_All {A} {P : A -> Type} l : (∀ x : A, In x l -> P x) -> All P l. Proof. induction l; cbn; constructor; auto. @@ -772,7 +772,7 @@ Proof. - move=> [=] <-. rewrite List.rev_length Nat.add_0_r in X. now rewrite Nat.sub_0_r. - simpl. eauto. -Qed. +Qed. Lemma Alli_shiftn {A} {P : nat -> A -> Type} k l n : Alli (fun x => P (n + x)) k l -> Alli P (n + k) l. @@ -936,7 +936,7 @@ Proof. Qed. Lemma OnOne2_nth_error {A} (l l' : list A) n t P : - OnOne2 P l l' -> + OnOne2 P l l' -> nth_error l n = Some t -> ∑ t', (nth_error l' n = Some t') * ((t = t') + (P t t')). @@ -950,7 +950,7 @@ Proof. Qed. Lemma OnOne2_nth_error_r {A} (l l' : list A) n t' P : - OnOne2 P l l' -> + OnOne2 P l l' -> nth_error l' n = Some t' -> ∑ t, (nth_error l n = Some t) * ((t = t') + (P t t')). @@ -965,7 +965,7 @@ Qed. -Lemma OnOne2_impl_All_r {A} (P : A -> A -> Type) (Q : A -> Type) l l' : +Lemma OnOne2_impl_All_r {A} (P : A -> A -> Type) (Q : A -> Type) l l' : (forall x y, Q x -> P x y -> Q y) -> OnOne2 P l l' -> All Q l -> All Q l'. Proof. @@ -1017,8 +1017,8 @@ Proof. intros H; induction 1; constructor; try inv H; intuition. Qed. -Lemma OnOne2i_app {A} (P : nat -> A -> A -> Type) {i l tl tl'} : - OnOne2i P (#|l| + i) tl tl' -> +Lemma OnOne2i_app {A} (P : nat -> A -> A -> Type) {i l tl tl'} : + OnOne2i P (#|l| + i) tl tl' -> OnOne2i P i (l ++ tl) (l ++ tl'). Proof. induction l in i |- *; simpl; try constructor; eauto. eapply IHl. now rewrite Nat.add_succ_r. @@ -1151,7 +1151,7 @@ Proof. Qed. Lemma OnOne2i_nth_error {A} (l l' : list A) i n t P : - OnOne2i P i l l' -> + OnOne2i P i l l' -> nth_error l n = Some t -> ∑ t', (nth_error l' n = Some t') * ((t = t') + (P (i + n)%nat t t')). @@ -1166,7 +1166,7 @@ Proof. Qed. Lemma OnOne2i_nth_error_r {A} i (l l' : list A) n t' P : - OnOne2i P i l l' -> + OnOne2i P i l l' -> nth_error l' n = Some t' -> ∑ t, (nth_error l n = Some t) * ((t = t') + (P (i + n)%nat t t')). @@ -1197,8 +1197,8 @@ Proof. intros a; induction 1; constructor; try inv a; intuition. Qed. -Lemma OnOne2All_app {A B} (P : B -> A -> A -> Type) {i i' l tl tl'} : - OnOne2All P i tl tl' -> +Lemma OnOne2All_app {A B} (P : B -> A -> A -> Type) {i i' l tl tl'} : + OnOne2All P i tl tl' -> #|i'| = #|l| -> OnOne2All P (i' ++ i) (l ++ tl) (l ++ tl'). Proof. induction l in i, i' |- *; simpl; try constructor; eauto. @@ -1254,7 +1254,7 @@ Qed. Lemma OnOne2All_ind_l : forall A B (R : list A -> B -> A -> A -> Type) (P : forall L i l l', OnOne2All (R L) i l l' -> Type), - (forall L b bs x y l (r : R L b x y) (len : #|bs| = #|l|), + (forall L b bs x y l (r : R L b x y) (len : #|bs| = #|l|), P L (b :: bs) (x :: l) (y :: l) (OnOne2All_hd _ _ _ _ _ l r len)) -> (forall L b bs x l l' (h : OnOne2All (R L) bs l l'), P L bs l l' h -> @@ -1343,7 +1343,7 @@ Proof. Qed. Lemma OnOne2All_nth_error {A B} {i : list B} (l l' : list A) n t P : - OnOne2All P i l l' -> + OnOne2All P i l l' -> nth_error l n = Some t -> ∑ t', (nth_error l' n = Some t') * ((t = t') + (∑ i', (nth_error i n = Some i') * P i' t t')). @@ -1357,7 +1357,7 @@ Proof. Qed. Lemma OnOne2All_nth_error_r {A B} (i : list B) (l l' : list A) n t' P : - OnOne2All P i l l' -> + OnOne2All P i l l' -> nth_error l' n = Some t' -> ∑ t, (nth_error l n = Some t) * ((t = t') + (∑ i', (nth_error i n = Some i') * P i' t t')). @@ -1371,7 +1371,7 @@ Proof. intros [= ->]. exists t'; intuition auto. Qed. -Lemma OnOne2All_impl_All_r {A B} (P : B -> A -> A -> Type) (Q : A -> Type) i l l' : +Lemma OnOne2All_impl_All_r {A B} (P : B -> A -> A -> Type) (Q : A -> Type) i l l' : (forall i x y, Q x -> P i x y -> Q y) -> OnOne2All P i l l' -> All Q l -> All Q l'. Proof. @@ -1647,7 +1647,7 @@ Qed. Lemma nth_error_all {A} {P : A -> Type} {l : list A} {n x} : nth_error l n = Some x -> All P l -> P x. Proof. - intros Hnth HPl. + intros Hnth HPl. induction l in n, Hnth, HPl |- *. destruct n; discriminate. destruct n; cbn in Hnth. - inversion Hnth. subst. inversion HPl. eauto. @@ -1867,7 +1867,7 @@ Proof. induction Hall; destruct n; simpl; try congruence. auto. Qed. -Lemma All2_All2_mix {A B} {P Q : A -> B -> Type} l l' : +Lemma All2_All2_mix {A B} {P Q : A -> B -> Type} l l' : All2 P l l' -> All2 Q l l' -> All2 (fun x y => P x y × Q x y) l l'. @@ -1973,10 +1973,10 @@ Proof. intros H1 H2 Hl. induction H1 in l', H2, Hl |- *; destruct l'; depelim Hl. - econstructor. - - econstructor; firstorder. eapply IHAll; firstorder. + - econstructor; firstorder. eapply IHAll; firstorder. Qed. -Lemma All_All_All2 {A} (P Q : A -> Prop) l l' : +Lemma All_All_All2 {A} (P Q : A -> Prop) l l' : All P l -> All Q l' -> #|l| = #|l'| -> All2 (fun x y => P x /\ Q y) l l'. Proof. induction l in l' |- *; destruct l'; simpl; auto => //. @@ -2104,7 +2104,7 @@ Lemma Forall2_map_right {A B C} (P : A -> B -> Prop) (f : C -> B) (l : list A) ( Proof. split; intros. + eapply Forall2_map_inv. now rewrite map_id. - + rewrite -(map_id l). now eapply Forall2_map. + + rewrite -(map_id l). now eapply Forall2_map. Qed. Lemma Forall2_and {A B} (R R' : A -> B -> Prop) l l' @@ -2810,7 +2810,7 @@ Proof. Qed. Lemma forallb2P {A B} (P : A -> B -> Prop) (p : A -> B -> bool) l l' : - (forall x y, reflect (P x y) (p x y)) -> + (forall x y, reflect (P x y) (p x y)) -> reflect (Forall2 P l l') (forallb2 p l l'). Proof. intros Hp. @@ -2824,7 +2824,7 @@ Qed. (** All, All2 and In interactions. *) -Lemma All2_In {A B} (P : A -> B -> Type) l l' x : In x l -> +Lemma All2_In {A B} (P : A -> B -> Type) l l' x : In x l -> All2 P l l' -> ∥ ∑ x', P x x' ∥. Proof. induction 2; simpl in H => //. @@ -2833,7 +2833,7 @@ Proof. now eapply IHX. Qed. -Lemma All2_In_right {A B} (P : A -> B -> Type) l l' x' : In x' l' -> +Lemma All2_In_right {A B} (P : A -> B -> Type) l l' x' : In x' l' -> All2 P l l' -> ∥ ∑ x, P x x' ∥. Proof. induction 2; simpl in H => //. @@ -2842,7 +2842,7 @@ Proof. now eapply IHX. Qed. -Lemma All_In {A} (P : A -> Type) l x : In x l -> +Lemma All_In {A} (P : A -> Type) l x : In x l -> All P l -> ∥ P x ∥. Proof. induction 2; simpl in H => //. @@ -2851,7 +2851,7 @@ Proof. now eapply IHX. Qed. -Lemma In_Forall {A} {P : A -> Prop} l : +Lemma In_Forall {A} {P : A -> Prop} l : (forall x, In x l -> P x) -> Forall P l. Proof. @@ -2860,7 +2860,7 @@ Proof. intros x xin; apply H; simpl; auto. Qed. -Lemma All_forall {X Y} (f:X->Y->Prop) xs: +Lemma All_forall {X Y} (f:X->Y->Prop) xs: All (fun a => forall b, f a b) xs -> (forall b, All (fun a => f a b) xs). Proof. @@ -2882,7 +2882,7 @@ Proof. induction 1; simpl; constructor; try congruence. Qed. Lemma All2i_nth_impl_gen {A B} (R : nat -> A -> B -> Type) n l l' : All2i R n l l' -> - All2i (fun i x y => + All2i (fun i x y => (if i //. - apply Nat.ltb_nlt in ltb. + apply Nat.ltb_nlt in ltb. destruct (Nat.ltb i n) eqn:ltb'; simpl in *. + eapply Nat.ltb_lt in ltb'. lia. + eapply Nat.ltb_nlt in ltb'. @@ -2911,7 +2911,7 @@ Proof. now rewrite Nat.sub_0_r in X. Qed. -Lemma All2i_nth_error_l {A B} (P : nat -> A -> B -> Type) l l' n x k : +Lemma All2i_nth_error_l {A B} (P : nat -> A -> B -> Type) l l' n x k : All2i P k l l' -> nth_error l n = Some x -> ∑ c, nth_error l' n = Some c × P (k + n)%nat x c. @@ -2925,7 +2925,7 @@ Proof. now rewrite Nat.add_succ_r. Qed. -Lemma All2i_nth_error_r {A B} (P : nat ->A -> B -> Type) l l' n x k : +Lemma All2i_nth_error_r {A B} (P : nat ->A -> B -> Type) l l' n x k : All2i P k l l' -> nth_error l' n = Some x -> ∑ c, nth_error l n = Some c × P (k + n)%nat c x. @@ -3060,8 +3060,8 @@ Proof. induction 1; constructor; auto. Qed. -Lemma All_fold_app_inv {A} {P} (Γ Δ : list A) : - All_fold P (Γ ++ Δ) -> +Lemma All_fold_app_inv {A} {P} (Γ Δ : list A) : + All_fold P (Γ ++ Δ) -> All_fold P Δ × All_fold (fun Γ => P (Γ ++ Δ)) Γ. Proof. induction Γ in Δ |- *; split; auto. constructor. @@ -3109,17 +3109,17 @@ Qed. Section All_fold. Context {A} {P : list A -> A -> Type}. - Lemma All_fold_impl Q Γ : - All_fold P Γ -> + Lemma All_fold_impl Q Γ : + All_fold P Γ -> (forall Γ x, P Γ x -> Q Γ x) -> All_fold Q Γ. Proof using Type. induction 1; simpl; intros => //; constructor; eauto. Qed. - Lemma All_fold_app Γ Δ : - All_fold (fun Γ => P (Γ ++ Δ)) Γ -> - All_fold P Δ -> + Lemma All_fold_app Γ Δ : + All_fold (fun Γ => P (Γ ++ Δ)) Γ -> + All_fold P Δ -> All_fold P (Γ ++ Δ). Proof using Type. induction 1; simpl; intros => //. @@ -3129,7 +3129,7 @@ End All_fold. Section Alli_All_fold. Context {A : Type}. - Lemma Alli_All_fold {P : nat -> A -> Type} {n Γ} : + Lemma Alli_All_fold {P : nat -> A -> Type} {n Γ} : Alli P n Γ <~> All_fold (fun Γ d => P (n + #|Γ|) d) (List.rev Γ). Proof using Type. @@ -3149,7 +3149,7 @@ Section Alli_All_fold. now constructor; [len in p|constructor]. Qed. - Lemma Alli_rev_All_fold (P : nat -> A -> Type) n Γ : + Lemma Alli_rev_All_fold (P : nat -> A -> Type) n Γ : Alli P n (List.rev Γ) -> All_fold (fun Γ d => P (n + #|Γ|) d) Γ. Proof using Type. @@ -3157,7 +3157,7 @@ Section Alli_All_fold. now rewrite List.rev_involutive. Qed. - Lemma All_fold_Alli_rev (P : nat -> A -> Type) n Γ : + Lemma All_fold_Alli_rev (P : nat -> A -> Type) n Γ : All_fold (fun Γ d => P (n + #|Γ|) d) Γ -> Alli P n (List.rev Γ). Proof using Type. @@ -3169,13 +3169,13 @@ End Alli_All_fold. Section All2_fold. Context {A} {P : list A -> list A -> A -> A -> Type}. - Lemma All2_fold_All2 (Q : A -> A -> Type) {Γ Δ : list A} : + Lemma All2_fold_All2 (Q : A -> A -> Type) {Γ Δ : list A} : All2_fold (fun _ _ => Q) Γ Δ <~> All2 Q Γ Δ. Proof using Type. split; induction 1; simpl; constructor; auto. Qed. - + Lemma All2_fold_refl: (forall Δ x, P Δ Δ x x) -> forall Δ : list A, All2_fold P Δ Δ. Proof using Type. @@ -3238,11 +3238,11 @@ Section All2_fold. depelim H'; specialize (IHΔ H'); intuition auto; constructor; auto. Qed. - - Lemma All2_fold_impl_ind {P' Γ Δ} : + + Lemma All2_fold_impl_ind {P' Γ Δ} : All2_fold P Γ Δ -> - (forall Γ Δ d d', - All2_fold P Γ Δ -> + (forall Γ Δ d d', + All2_fold P Γ Δ -> All2_fold P' Γ Δ -> P Γ Δ d d' -> P' Γ Δ d d') -> @@ -3261,7 +3261,7 @@ Section All2_fold. induction H; constructor; simpl; eauto. Qed. - Lemma All2_fold_forallb2 (Pb : A -> A -> bool) Γ Δ : + Lemma All2_fold_forallb2 (Pb : A -> A -> bool) Γ Δ : All2_fold (fun _ _ => Pb) Γ Δ -> forallb2 Pb Γ Δ. Proof using Type. @@ -3323,7 +3323,7 @@ Lemma All_fold_prod {A} (P : list A -> A -> Type) Q Γ Δ : #|Γ| = #|Δ| -> All_fold P Γ -> All_fold P Δ -> - (forall Δ Δ' x y, + (forall Δ Δ' x y, All_fold P Δ -> All_fold P Δ' -> All2_fold Q Δ Δ' -> P Δ x -> P Δ' y -> Q Δ Δ' x y) -> @@ -3335,7 +3335,7 @@ Proof. - eauto. Qed. -Lemma All2_fold_All_fold_mix {A P Q} {l l' : list A} : +Lemma All2_fold_All_fold_mix {A P Q} {l l' : list A} : All2_fold P l l' -> All_fold Q l -> All_fold Q l' -> @@ -3344,14 +3344,14 @@ Proof. induction 1; [constructor|] => l r; depelim l; depelim r; constructor; auto. Qed. -Lemma All2_fold_All_fold_mix_inv {A} {P Q} {l l' : list A} : +Lemma All2_fold_All_fold_mix_inv {A} {P Q} {l l' : list A} : All2_fold (fun Γ Γ' x y => Q Γ x × Q Γ' y × P Γ Γ' x y) l l' -> All2_fold P l l' × All_fold Q l × All_fold Q l'. Proof. induction 1; intuition (try constructor; auto). Qed. -Lemma All_fold_All2_fold_impl {A} {P Q} {Γ : list A} : +Lemma All_fold_All2_fold_impl {A} {P Q} {Γ : list A} : All_fold P Γ -> (forall Γ d, All_fold P Γ -> All2_fold Q Γ Γ -> P Γ d -> Q Γ Γ d d) -> All2_fold Q Γ Γ. @@ -3359,7 +3359,7 @@ Proof. intros a H; induction a; constructor; auto. Qed. -Lemma All_fold_All2_fold {A P} {Γ : list A} : +Lemma All_fold_All2_fold {A P} {Γ : list A} : All_fold (fun Γ d => P Γ Γ d d) Γ <~> All2_fold P Γ Γ. Proof. @@ -3396,9 +3396,9 @@ Qed. Set Equations Transparent. Section map_All. - Context {A B C} {Q : C -> Type} {P : C -> A -> Prop} + Context {A B C} {Q : C -> Type} {P : C -> A -> Prop} (fn : forall (x : A) , (forall (y:C), Q y -> P y x) -> B). - + Equations? map_All (l : list A) (Hl : forall y, Q y -> ∥ All (P y) l ∥) : list B := | [], _ := [] | x :: xs, h := fn x _ :: map_All xs _. @@ -3409,7 +3409,7 @@ Section map_All. End map_All. Lemma All_map_All {A B C} {Q : C -> Type} {P : C -> A -> Prop} - {Q' : B -> Type} {R : C -> A -> Prop} + {Q' : B -> Type} {R : C -> A -> Prop} f args (ha: forall y : C, Q y -> ∥ All (R y) args ∥) : (forall y : C, Q y -> All (P y) args) -> (forall x y rx, P y x -> Q' (f x rx)) -> @@ -3420,9 +3420,9 @@ Proof. - intros ha hf y hy. pose proof (ha y hy). depelim X0. econstructor; eauto. eapply X; eauto. intros. eapply ha in X1. now depelim X1. Qed. - + Lemma map_All_length {A B C : Type} {Q : C -> Type} {P : C -> A -> Prop} - (fn : forall x : A, (forall y : C, Q y -> P y x) -> B) + (fn : forall x : A, (forall y : C, Q y -> P y x) -> B) (l : list A) (Hl : forall y : C, Q y -> ∥ All (P y) l ∥) : #|map_All fn l Hl| = #|l|. Proof. @@ -3430,7 +3430,7 @@ Proof. Qed. #[export] Hint Rewrite @map_All_length : len. -Lemma nth_error_map_All {A B C} {Q : C -> Type} {P : C -> A -> Prop} +Lemma nth_error_map_All {A B C} {Q : C -> Type} {P : C -> A -> Prop} (fn : forall (x : A) , (forall (y:C), Q y -> P y x) -> B) : forall l : list A, forall H : (forall y : C, Q y -> ∥ All (P y) l ∥), forall n x, @@ -3445,7 +3445,7 @@ Proof. + now eapply H. Qed. -Lemma All2_map2_left {A B C D} {P : A -> A -> Type} Q (R : B -> D -> Type) {f : B -> C -> A} {l l' l'' l'''} : +Lemma All2_map2_left {A B C D} {P : A -> A -> Type} Q (R : B -> D -> Type) {f : B -> C -> A} {l l' l'' l'''} : All2 R l l''' -> All2 Q l' l'' -> #|l| = #|l'| -> @@ -3461,14 +3461,14 @@ Proof. simpl. constructor; auto. eapply hPQ; eauto. Qed. -Lemma All2_map2_left_All3 {A B C} {P : A -> A -> Type} {f : B -> C -> A} {l l' l''} : +Lemma All2_map2_left_All3 {A B C} {P : A -> A -> Type} {f : B -> C -> A} {l l' l''} : All3 (fun x y z => P (f x y) z) l l' l'' -> All2 P (map2 f l l') l''. Proof. induction 1; constructor; auto. Qed. -Lemma All3_impl {A B C} {P Q : A -> B -> C -> Type} {l l' l''} : +Lemma All3_impl {A B C} {P Q : A -> B -> C -> Type} {l l' l''} : All3 P l l' l'' -> (forall x y z, P x y z -> Q x y z) -> All3 Q l l' l''. @@ -3478,7 +3478,7 @@ Qed. Lemma map2_app {A B C} (f : A -> B -> C) l0 l0' l1 l1' : #|l0| = #|l1| -> #|l0'| = #|l1'| -> - map2 f (l0 ++ l0') (l1 ++ l1') = + map2 f (l0 ++ l0') (l1 ++ l1') = map2 f l0 l1 ++ map2 f l0' l1'. Proof. induction l0 in l0', l1, l1' |- *; simpl; auto. diff --git a/template-coq/theories/utils/ByteCompare.v b/template-coq/theories/utils/ByteCompare.v index 0ffc097bb..b83f5691e 100644 --- a/template-coq/theories/utils/ByteCompare.v +++ b/template-coq/theories/utils/ByteCompare.v @@ -522,8 +522,8 @@ Definition to_N (x : byte) := end. End ByteN. -Definition eqb (x y : byte) := +Definition eqb (x y : byte) := N.eqb (ByteN.to_N x) (ByteN.to_N y). -Definition compare (x y : byte) := +Definition compare (x y : byte) := N.compare (ByteN.to_N x) (ByteN.to_N y). diff --git a/template-coq/theories/utils/ByteCompareSpec.v b/template-coq/theories/utils/ByteCompareSpec.v index 0d01b8a68..f93ed1def 100644 --- a/template-coq/theories/utils/ByteCompareSpec.v +++ b/template-coq/theories/utils/ByteCompareSpec.v @@ -36,7 +36,7 @@ Lemma compare_equiv x y : compare x y = N.compare (Byte.to_N x) (Byte.to_N y). Proof. reflexivity. Qed. -(* +(* Proof. destruct x; abstract (destruct y; exact eq_refl). Qed. *) @@ -93,7 +93,7 @@ Proof. (* destruct x; cbn; abstract (destruct y; cbn; exact eq_refl). *) Qed. -Global Program Instance byte_reflect_eq : ReflectEq byte := +Global Program Instance byte_reflect_eq : ReflectEq byte := {| ReflectEq.eqb := eqb |}. Next Obligation. rewrite eqb_compare. diff --git a/template-coq/theories/utils/MCCompare.v b/template-coq/theories/utils/MCCompare.v index 99c8eea34..2597bcfe7 100644 --- a/template-coq/theories/utils/MCCompare.v +++ b/template-coq/theories/utils/MCCompare.v @@ -26,11 +26,11 @@ Definition comparison_trans p q := match p, q with | Datatypes.Eq, c => Some c | c, Datatypes.Eq => Some c - | Datatypes.Lt, Datatypes.Gt => None + | Datatypes.Lt, Datatypes.Gt => None | Datatypes.Gt, Datatypes.Lt => None | c, _ => Some c end. - + Lemma compare_cont_trans {A} (cmp : A -> A -> comparison) : (forall c x y z, cmp x y = c -> cmp y z = c -> cmp x z = c) -> (forall x y, cmp x y = Datatypes.Eq -> x = y) -> @@ -58,15 +58,15 @@ Qed. (** Facts about booleans, characters and strings *) -Module BoolOT <: UsualOrderedType. +Module BoolOT <: UsualOrderedType. Definition t := bool. Definition compare (x y : bool) : comparison := if x then if y then Eq else Gt else if y then Lt else Eq. - + Definition lt (x y : bool) := if x then False else y = true. - + Definition compare_spec (x y : bool) : CompareSpec (x = y) (lt x y) (lt y x) (compare x y). Proof. destruct x, y. @@ -83,7 +83,7 @@ Module BoolOT <: UsualOrderedType. Proof. decide equality. Defined. - + Definition lt_strorder : StrictOrder lt. Proof. constructor. @@ -100,7 +100,7 @@ Module BoolOT <: UsualOrderedType. (* Bonus *) Definition eqb (l1 l2 : t) : bool := match compare l1 l2 with Eq => true | _ => false end. - + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. End BoolOT. @@ -109,7 +109,7 @@ Notation bool_compare := BoolOT.compare. Local Ltac trd := cbn in *; try reflexivity; try discriminate. -Module ListOrderedType (A : UsualOrderedType) <: UsualOrderedType. +Module ListOrderedType (A : UsualOrderedType) <: UsualOrderedType. Definition t := list A.t. Import List. Import ListNotations. @@ -123,7 +123,7 @@ Module ListOrderedType (A : UsualOrderedType) <: UsualOrderedType. Definition eq : t -> t -> Prop := eq. Definition eq_equiv : Equivalence eq := _. - + Inductive lt_ : t -> t -> Prop := | lt_nil_cons hd tl : lt_ [] (hd :: tl) | lt_cons_cons_hd hd tl hd' tl' : A.lt hd hd' -> lt_ (hd :: tl) (hd' :: tl') @@ -209,14 +209,14 @@ Module ListOrderedType (A : UsualOrderedType) <: UsualOrderedType. eapply transitivity in H. 2:eassumption. apply compare_lt_lt in H. rewrite compare_sym H //. Qed. - + (* Bonus *) Definition eqb (l1 l2 : t) : bool := match compare l1 l2 with Eq => true | _ => false end. - + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. - Program Definition eqb_dec (x y : t) : { x = y } + { x <> y } := + Program Definition eqb_dec (x y : t) : { x = y } + { x <> y } := match eqb x y with | true => left _ | false => right _ diff --git a/template-coq/theories/utils/MCList.v b/template-coq/theories/utils/MCList.v index b11fa808c..1b1dfa8d1 100644 --- a/template-coq/theories/utils/MCList.v +++ b/template-coq/theories/utils/MCList.v @@ -62,9 +62,9 @@ Fixpoint map2 {A B C} (f : A -> B -> C) (l : list A) (l' : list B) : list C := | hd :: tl, hd' :: tl' => f hd hd' :: map2 f tl tl' | _, _ => [] end. - + Lemma map2_ext {A B C} (f g : A -> B -> C) (l : list A) (l' : list B) : - (forall x y, f x y = g x y) -> + (forall x y, f x y = g x y) -> map2 f l l' = map2 g l l'. Proof. intros H. @@ -581,7 +581,7 @@ Proof. - simpl. eauto. Qed. -Lemma rev_map_spec {A B} (f : A -> B) (l : list A) : +Lemma rev_map_spec {A B} (f : A -> B) (l : list A) : rev_map f l = List.rev (map f l). Proof. unfold rev_map. @@ -602,7 +602,7 @@ Proof. induction n in s, x, xs |- *. - unfold skipn. now intros ->. - destruct s; simpl. intros H; discriminate. apply IHn. -Qed. +Qed. Lemma skipn_all {A} (l : list A) : skipn #|l| l = []. Proof. @@ -617,8 +617,8 @@ Proof. rewrite !skipn_S. apply IHl. lia. Qed. -Lemma skipn_mapi_rec {A B} n (f : nat -> A -> B) k (l : list A) : - skipn n (mapi_rec f l k) = +Lemma skipn_mapi_rec {A B} n (f : nat -> A -> B) k (l : list A) : + skipn n (mapi_rec f l k) = mapi_rec f (skipn n l) (n + k). Proof. induction n in f, l, k |- *. @@ -629,7 +629,7 @@ Proof. now rewrite Nat.add_succ_r. Qed. -Lemma skipn_map_length {A B} n (f : A -> B) (l : list A) : +Lemma skipn_map_length {A B} n (f : A -> B) (l : list A) : #|skipn n (map f l)| = #|skipn n l|. Proof. now rewrite !List.skipn_length; len. @@ -670,9 +670,9 @@ Proof. Qed. Fixpoint split_at_aux {A} (n : nat) (acc : list A) (l : list A) : list A * list A := - match n with + match n with | 0 => (List.rev acc, l) - | S n' => + | S n' => match l with | [] => (List.rev acc, []) | hd :: l' => split_at_aux n' (hd :: acc) l' @@ -688,7 +688,7 @@ Proof. now rewrite app_nil_r. now rewrite app_nil_r. now rewrite app_nil_r. - rewrite IHn. simpl. + rewrite IHn. simpl. now rewrite -app_assoc /=. Qed. @@ -896,7 +896,7 @@ Section ListSize. : list_size l >= length l. Proof using Type. induction l; simpl; lia. - Qed. + Qed. End ListSize. @@ -1040,7 +1040,7 @@ Proof. * simpl. revert Hn. rewrite nth_error_app_lt ?unfold_length //; try lia. auto. Qed. -Lemma In_unfold_inj {A} (f : nat -> A) n i : +Lemma In_unfold_inj {A} (f : nat -> A) n i : (forall i j, f i = f j -> i = j) -> In (f i) (unfold n f) -> i < n. Proof. @@ -1054,7 +1054,7 @@ Proof. * destruct H. Qed. -Lemma forallb_unfold {A} (f : A -> bool) (g : nat -> A) n : +Lemma forallb_unfold {A} (f : A -> bool) (g : nat -> A) n : (forall x, x < n -> f (g x)) -> forallb f (unfold n g). Proof. @@ -1116,8 +1116,8 @@ Lemma firstn_app_left_rem (A : Type) (n : nat) (l1 l2 : list A) k : firstn k (l1 ++ l2) = l1 ++ firstn n l2. Proof. intros ->; apply firstn_app_2. Qed. -Lemma firstn_app_left {A} n (l l' : list A) : - n = #|l| -> +Lemma firstn_app_left {A} n (l l' : list A) : + n = #|l| -> firstn n (l ++ l') = l. Proof. intros ->. @@ -1148,7 +1148,7 @@ Fixpoint map2i_rec {A B C} (f : nat -> A -> B -> C) i (l : list A) (l' : list B) end. Definition map2i {A B C} (f : nat -> A -> B -> C) := map2i_rec f 0. -Lemma mapi_map2 {A B C D} (f : nat -> A -> B) (g : C -> D -> A) l l' : +Lemma mapi_map2 {A B C D} (f : nat -> A -> B) (g : C -> D -> A) l l' : mapi f (map2 g l l') = map2i (fun i x y => f i (g x y)) l l'. Proof. unfold mapi, map2i. generalize 0. @@ -1156,7 +1156,7 @@ Proof. apply IHl. Qed. -Lemma map2_mapi {A A' B B' C} (f : nat -> A -> B) (f' : nat-> A' -> B') (g : B -> B' -> C) l l' : +Lemma map2_mapi {A A' B B' C} (f : nat -> A -> B) (f' : nat-> A' -> B') (g : B -> B' -> C) l l' : map2 g (mapi f l) (mapi f' l') = map2i (fun i x y => g (f i x) (f' i y)) l l'. Proof. unfold mapi, map2i. generalize 0. @@ -1207,14 +1207,14 @@ Proof. funelim (map_In l g) => //; simpl; rewrite (H f0); trivial. Qed. -Lemma rev_repeat {A : Type} (n : nat) (a : A) : +Lemma rev_repeat {A : Type} (n : nat) (a : A) : List.rev (repeat a n) = repeat a n. Proof. induction n. - reflexivity. - replace (S n) with (n + 1) at 2 by lia. cbn [repeat]. cbn. rewrite IHn. - now rewrite repeat_app. + now rewrite repeat_app. Qed. @@ -1366,7 +1366,7 @@ Proof. now rewrite (H f0). Qed. -Lemma In_size {A B} {x : A} {l : list A} (proj : A -> B) (size : B -> nat) : +Lemma In_size {A B} {x : A} {l : list A} (proj : A -> B) (size : B -> nat) : In x l -> size (proj x) < S (list_size (size ∘ proj) l). Proof. induction l; cbn => //. @@ -1378,10 +1378,10 @@ Proof. destruct l; cbn; congruence. Qed. -Definition remove_last {A} (args : list A) := +Definition remove_last {A} (args : list A) := List.firstn (#|args| - 1) args. -Lemma remove_last_app {A} (l : list A) x : +Lemma remove_last_app {A} (l : list A) x : remove_last (l ++ [x]) = l. Proof. unfold remove_last. cbn. len. @@ -1397,7 +1397,7 @@ Proof. intros. rewrite remove_last_app last_last //. Qed. -Lemma forallb_repeat {A} {p : A -> bool} {a : A} {n} : +Lemma forallb_repeat {A} {p : A -> bool} {a : A} {n} : p a -> forallb p (repeat a n). Proof. @@ -1406,13 +1406,13 @@ Proof. now rewrite pa IHn. Qed. -Lemma map_repeat {A B} (f : A -> B) a n : +Lemma map_repeat {A B} (f : A -> B) a n : map f (repeat a n) = repeat (f a) n. Proof. induction n; cbn; congruence. Qed. -Lemma map2_length : +Lemma map2_length : forall {A B C : Type} (f : A -> B -> C) (l : list A) (l' : list B), #| map2 f l l'| = min #|l| #|l'|. Proof. intros. induction l in l' |- *; cbn. diff --git a/template-coq/theories/utils/MCOption.v b/template-coq/theories/utils/MCOption.v index 9621c6675..217957403 100644 --- a/template-coq/theories/utils/MCOption.v +++ b/template-coq/theories/utils/MCOption.v @@ -143,7 +143,7 @@ Proof. - discriminate. Qed. -Lemma option_map_Some {A B} (f : A -> B) (o : option A) x : +Lemma option_map_Some {A B} (f : A -> B) (o : option A) x : option_map f o = Some x -> ∑ y, (o = Some y) /\ (x = f y). Proof. @@ -151,7 +151,7 @@ Proof. move=> [] <-. exists a; auto. Qed. -Lemma reflect_option_default {A} {P : A -> Type} {p : A -> bool} : +Lemma reflect_option_default {A} {P : A -> Type} {p : A -> bool} : (forall x, reflectT (P x) (p x)) -> forall x, reflectT (option_default P x unit) (option_default p x true). Proof. diff --git a/template-coq/theories/utils/MCPred.v b/template-coq/theories/utils/MCPred.v index 5bcb3cb27..b34e4b29f 100644 --- a/template-coq/theories/utils/MCPred.v +++ b/template-coq/theories/utils/MCPred.v @@ -4,7 +4,7 @@ From Equations Require Import Equations. Definition predA {A} (p q : pred A) : pred A := (fun i => p i ==> q i). -(* +(* Definition orP (p q : nat -> bool) (n : nat) : bool := p n || q n. diff --git a/template-coq/theories/utils/MCPrelude.v b/template-coq/theories/utils/MCPrelude.v index cd457113c..472ea0184 100644 --- a/template-coq/theories/utils/MCPrelude.v +++ b/template-coq/theories/utils/MCPrelude.v @@ -72,7 +72,7 @@ Ltac tc := try typeclasses eauto. Create HintDb terms. -(** This tactic helps rewrite with all the length lemmas available +(** This tactic helps rewrite with all the length lemmas available in the library *) Ltac len := autorewrite with len; cbn. Tactic Notation "len" "in" hyp(cl) := autorewrite with len in cl. @@ -116,9 +116,9 @@ Ltac easy ::= easy0 || solve [intuition eauto 3 with core terms]. Ltac inv H := inversion_clear H. -(** Turns a subterm of the goal into an evar + equality subgoal +(** Turns a subterm of the goal into an evar + equality subgoal for easier lemma application. *) -Tactic Notation "relativize" open_constr(c) := - let ty := type of c in +Tactic Notation "relativize" open_constr(c) := + let ty := type of c in let x := fresh in evar (x : ty); replace c with x; subst x. \ No newline at end of file diff --git a/template-coq/theories/utils/MCProd.v b/template-coq/theories/utils/MCProd.v index eac71b2e2..67e8840b1 100644 --- a/template-coq/theories/utils/MCProd.v +++ b/template-coq/theories/utils/MCProd.v @@ -25,7 +25,7 @@ Definition test_snd {A B} (f : B -> bool) (p : A * B) := Definition map_pair {A B C D} (f : A -> B) (g : C -> D) (p : A × C) : B × D := (f p.1, g p.2). - + Lemma on_snd_on_snd {A B C D} (f : C -> D) (g : B -> C) (d : A * B) : on_snd f (on_snd g d) = on_snd (fun x => f (g x)) d. Proof. @@ -51,8 +51,8 @@ Qed. Definition on_pi2 {A B C} (f : B -> B) (p : A * B * C) : A * B * C := (fst (fst p), f (snd (fst p)), snd p). -(** It would be tempting to import ssrbool here, however - https://github.com/coq/coq/issues/13486 prevents this. *) +(** It would be tempting to import ssrbool here, however + https://github.com/coq/coq/issues/13486 prevents this. *) Lemma andb_and b b' : b && b' <-> b /\ b'. Proof. apply andb_true_iff. Qed. @@ -76,7 +76,7 @@ Definition swap {A B : Type} (x : A * B) : B * A := Definition and_assum {A B : Type} (f : A) (f' : A -> B) : A × B := (f, f' f). - + (** n-ary cartesian products in Type, for shorter and more readable intro-patterns *) Reserved Notation "[ × P1 & P2 ]" (at level 0). @@ -123,4 +123,4 @@ Notation "[ × P1 , P2 , P3 , P4 , P5 , P6 , P7 , P8 , P9 & P10 ]" := (and10 P1 CRelationClasses.Reflexive P -> CRelationClasses.Reflexive Q -> CRelationClasses.Reflexive (fun x y => prod (P x y) (Q x y)). Proof. econstructor; reflexivity. -Defined. +Defined. diff --git a/template-coq/theories/utils/MCString.v b/template-coq/theories/utils/MCString.v index 141cb7e1d..c70ea5600 100644 --- a/template-coq/theories/utils/MCString.v +++ b/template-coq/theories/utils/MCString.v @@ -28,7 +28,7 @@ Definition parens (top : bool) (s : string) := Local Infix "::" := String.String. -Fixpoint string_of_uint n := +Fixpoint string_of_uint n := match n with | Nil => "" | D0 n => "0" :: string_of_uint n @@ -49,10 +49,10 @@ Definition string_of_nat n : string := #[global] Hint Resolve String.string_dec : eq_dec. -Definition string_of_positive p := +Definition string_of_positive p := string_of_uint (Pos.to_uint p). -Definition string_of_Z (z : Z) : string := +Definition string_of_Z (z : Z) : string := match z with | Z0 => "0" | Zpos p => string_of_positive p diff --git a/template-coq/theories/utils/MCUtils.v b/template-coq/theories/utils/MCUtils.v index 95e65de6e..a7557a3fc 100644 --- a/template-coq/theories/utils/MCUtils.v +++ b/template-coq/theories/utils/MCUtils.v @@ -75,11 +75,11 @@ Tactic Notation "toProp" ident(H) := | (_ apply Z.ltb_ge in H | (_ <=? _)%Z = false => apply Z.leb_gt in H | (_ =? _)%Z = false => apply Z.eqb_neq in H - + | is_true (_ && _) => apply andb_true_iff in H | (_ && _) = true => apply andb_true_iff in H | (_ && _) = false => apply andb_false_iff in H - + | is_true (_ || _) => apply orb_true_iff in H | (_ || _) = true => apply orb_true_iff in H | (_ || _) = false => apply orb_false_iff in H @@ -121,7 +121,7 @@ Tactic Notation "toProp" ident(H) "as" simple_intropattern(X) := | is_true (_ && _) => apply andb_true_iff in H; destruct H as X | (_ && _) = true => apply andb_true_iff in H; destruct H as X | (_ && _) = false => apply andb_false_iff in H; destruct H as X - + | is_true (_ || _) => apply orb_true_iff in H; destruct H as X | (_ || _) = true => apply orb_true_iff in H; destruct H as X | (_ || _) = false => apply orb_false_iff in H; destruct H as X diff --git a/template-coq/theories/utils/MC_ExtrOCamlZPosInt.v b/template-coq/theories/utils/MC_ExtrOCamlZPosInt.v index 6f5eeca88..dcc9efaae 100644 --- a/template-coq/theories/utils/MC_ExtrOCamlZPosInt.v +++ b/template-coq/theories/utils/MC_ExtrOCamlZPosInt.v @@ -66,4 +66,3 @@ Extract Constant Z.abs_N => "Stdlib.abs". (** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). For the moment we don't even try *) - \ No newline at end of file diff --git a/template-coq/theories/utils/ReflectEq.v b/template-coq/theories/utils/ReflectEq.v index fdd4ad90b..7eda6a046 100644 --- a/template-coq/theories/utils/ReflectEq.v +++ b/template-coq/theories/utils/ReflectEq.v @@ -70,7 +70,7 @@ Proof. Qed. #[global, program] Instance ReflectEq_EqDec {A} (R : ReflectEq A) : EqDec A := { - eq_dec := fun x y => + eq_dec := fun x y => match eqb x y with | true => left _ | false => right _ @@ -91,7 +91,7 @@ Definition eq_dec_to_bool {A} `{EqDec A} x y := (* Not an instance to avoid loops and making boolean definitions depend on sumbool ones *) #[global, program] -Definition EqDec_ReflectEq A {E : EqDec A} : ReflectEq A := +Definition EqDec_ReflectEq A {E : EqDec A} : ReflectEq A := {| eqb := eq_dec_to_bool |}. Next Obligation. Proof. diff --git a/template-coq/theories/utils/bytestring.v b/template-coq/theories/utils/bytestring.v index d8f0cad4b..4cdc3510f 100644 --- a/template-coq/theories/utils/bytestring.v +++ b/template-coq/theories/utils/bytestring.v @@ -5,12 +5,12 @@ * SPDX-License-Identifier: LGPL-2.1 WITH BedRock Exception for use over network, * see repository root for details. *) - + Require Coq.Strings.String ssrbool. Require Import ssreflect. Require Import Coq.NArith.NArith. Require Import Coq.micromega.Lia. -From Equations Require Import Equations. +From Equations Require Import Equations. Set Primitive Projections. Set Default Proof Using "Type". From MetaCoq.Template Require Import MCCompare ReflectEq. @@ -58,33 +58,33 @@ Module String. | EmptyString => y | String x xs => String x (append xs y) end. - + Notation "x ++ y" := (append x y) : bs_scope. - + Fixpoint to_string (b : t) : String.string := match b with | EmptyString => Strings.String.EmptyString | String x xs => Strings.String.String (Ascii.ascii_of_byte x) (to_string xs) end. - + Fixpoint of_string (b : String.string) : t := match b with | Strings.String.EmptyString => EmptyString | Strings.String.String x xs => String (Ascii.byte_of_ascii x) (of_string xs) end%bs. - + Fixpoint rev (acc s : t) : t := match s with | EmptyString => acc | String s ss => rev (String s acc) ss end. - + (** *** Substrings *) (** [substring n m s] returns the substring of [s] that starts at position [n] and of length [m]; if this does not make sense it returns [""] *) - + Fixpoint substring (n m : nat) (s : t) : t := match n, m, s with | O, O, _ => EmptyString @@ -93,7 +93,7 @@ Module String. | S n', _, EmptyString => s | S n', _, String c s' => substring n' m s' end. - + Fixpoint prefix (s1 s2 : t) {struct s1} : bool := match s1 with | EmptyString => true @@ -105,7 +105,7 @@ Module String. else false end end%bs. - + Fixpoint index (n : nat) (s1 s2 : t) {struct s2} : option nat := match s2 with | EmptyString => @@ -131,13 +131,13 @@ Module String. end end end%bs. - + Fixpoint length (l : t) : nat := match l with | EmptyString => 0 | String _ l => S (length l) end. - + Local Fixpoint contains (start: nat) (keys: list t) (fullname: t) :bool := match keys with | List.cons kh ktl => @@ -147,7 +147,7 @@ Module String. end | List.nil => true end. - + Fixpoint eqb (a b : t) : bool := match a , b with | EmptyString , EmptyString => true @@ -155,7 +155,7 @@ Module String. if ByteCompare.eqb x y then eqb xs ys else false | _ , _ => false end. - + Fixpoint compare (xs ys : t) : comparison := match xs , ys with | EmptyString , EmptyString => Eq @@ -192,7 +192,7 @@ Bind Scope bs_scope with bs. String Notation String.t String.parse String.print : bs_scope. Notation "x ++ y" := (String.append x y) : bs_scope. - + Import String. (** comparison *) @@ -271,7 +271,7 @@ Module StringOT <: UsualOrderedType. + constructor; auto. + red in H. rewrite H. constructor; auto. Qed. - + Theorem eq_refl : forall x : t, eq x x. Proof. reflexivity. @@ -333,7 +333,7 @@ Module StringOT <: UsualOrderedType. - apply lt_not_eq in H; contradiction. - apply lt_not_eq in H. symmetry in H0. contradiction. Qed. - + Lemma compare_refl x : compare x x = Eq. Proof. now apply compare_eq. @@ -353,12 +353,12 @@ Module StringOT <: UsualOrderedType. eapply lt_not_eq in H. elim H; reflexivity. * reflexivity. Qed. - + #[local] Instance lt_transitive : Transitive lt. Proof. red. eapply lt_trans. Qed. - + Lemma compare_sym (x y : string) : compare x y = CompOpp (compare y x). Proof. destruct (compare_spec x y). @@ -369,7 +369,7 @@ Module StringOT <: UsualOrderedType. red in H. now apply compare_lt. Qed. - + Lemma compare_trans (x y z : string) c : compare x y = c -> compare y z = c -> compare x z = c. Proof. destruct (compare_spec x y); subst; intros <-; @@ -378,7 +378,7 @@ Module StringOT <: UsualOrderedType. eapply transitivity in H. 2:eassumption. now apply compare_lt in H. Qed. - + Definition lt_irreflexive : Irreflexive lt. Proof. intro x. red; unfold lt. @@ -396,7 +396,7 @@ Module StringOT <: UsualOrderedType. Proof. unfold eq. intros x y e z t e'. subst; reflexivity. Qed. - + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. End StringOT. @@ -405,11 +405,11 @@ Notation string_compare := StringOT.compare. Notation string_compare_eq := StringOT.compare_eq. Notation CompareSpec_string := StringOT.compare_spec. -(** To perform efficient pretty printing, one needs to use a tree structure +(** To perform efficient pretty printing, one needs to use a tree structure to avoid quadratic overhead of appending strings. *) Module Tree. Local Open Scope bs_scope. - Inductive t := + Inductive t := | string : String.t -> t | append : t -> t -> t. @@ -422,21 +422,21 @@ Module Tree. | string s => cons s acc | append s s' => to_rev_list_aux s' (to_rev_list_aux s acc) end. - - Fixpoint to_string_acc acc l := + + Fixpoint to_string_acc acc l := match l with | nil => acc | cons s xs => to_string_acc (String.append s acc) xs end. - Definition to_string t := + Definition to_string t := let l := to_rev_list_aux t nil in to_string_acc "" l. - + (* Definition test := "a" ++ "b" ++ "v" ++ "c". Eval compute in to_string test. *) - (* Fixpoint to_string_acc t acc := + (* Fixpoint to_string_acc t acc := match t with | string s => String.append s acc | append s s' => to_string_acc s (to_string_acc s' acc) @@ -458,7 +458,7 @@ Module Tree. Definition print_list {A} (f : A -> t) (sep : t) (l : list A) : t := string_of_list_aux f sep l. - + Fixpoint concat (sep : t) (s : list t) : t := match s with | nil => EmptyString @@ -468,7 +468,7 @@ Module Tree. Definition parens (top : bool) (s : t) := if top then s else "(" ++ s ++ ")". - + End Tree. (* Tests *) diff --git a/template-coq/theories/utils/canonicaltries/CanonicalTries.v b/template-coq/theories/utils/canonicaltries/CanonicalTries.v index 73c3d109f..98c6964c0 100644 --- a/template-coq/theories/utils/canonicaltries/CanonicalTries.v +++ b/template-coq/theories/utils/canonicaltries/CanonicalTries.v @@ -15,15 +15,15 @@ Local Unset Case Analysis Schemes. Set Implicit Arguments. Module PTree. - + (** ** Representation of tries *) - + (** The type [tree'] of nonempty tries. Each constructor is of the form [NodeXYZ], where the bit [X] says whether there is a left subtree, [Y] whether there is a value at this node, and [Z] whether there is a right subtree. *) - - Inductive tree' (A: Type) : Type := + + Inductive tree' (A: Type) : Type := | Node001: tree' A -> tree' A | Node010: A -> tree' A | Node011: A -> tree' A -> tree' A @@ -31,13 +31,13 @@ Module PTree. | Node101: tree' A -> tree' A ->tree' A | Node110: tree' A -> A -> tree' A | Node111: tree' A -> A -> tree' A -> tree' A. - + (** The type [tree] of tries, empty or nonempty. *) - - Inductive tree (A: Type) : Type := + + Inductive tree (A: Type) : Type := | Empty: tree A | Nodes: tree' A -> tree A. - + Arguments Node001 {A} _. Arguments Node010 {A} _. Arguments Node011 {A} _ _. @@ -45,20 +45,20 @@ Module PTree. Arguments Node101 {A} _ _. Arguments Node110 {A} _ _. Arguments Node111 {A} _ _ _. - + Arguments Empty {A}. Arguments Nodes {A} _. - + Definition t := tree. - + Scheme tree'_ind := Induction for tree' Sort Prop. - + (** A smart constructor similar to the [Node'] smart constructor of the original implementation. Given a (possibly empty) left subtree, a (possibly absent) value, and a (possibly empty) right subtree, it builds the corresponding tree. *) - - Definition Node {A} (l: tree A) (o: option A) (r: tree A) : tree A := + + Definition Node {A} (l: tree A) (o: option A) (r: tree A) : tree A := match l,o,r with | Empty, None, Empty => Empty | Empty, None, Nodes r' => Nodes (Node001 r') @@ -69,15 +69,15 @@ Module PTree. | Nodes l', Some x, Empty => Nodes (Node110 l' x) | Nodes l', Some x, Nodes r' => Nodes (Node111 l' x r') end. - + (** ** Basic operations: [empty], [get], [set], [remove] *) - + Definition empty (A: Type) : tree A := Empty. - + (** Operations such as [get] follow a common pattern: first, a recursive function [get'] over nonempty tries; then, a non-recursive function [get] to handle empty tries too. *) - + Fixpoint get' {A} (p: positive) (m: tree' A) : option A := match p, m with | xH, Node001 _ => None @@ -102,23 +102,23 @@ Module PTree. | xI q, Node110 _ _ => None | xI q, Node111 _ _ m' => get' q m' end. - + Definition get {A} (p: positive) (m: tree A) : option A := match m with | Empty => None | Nodes m' => get' p m' end. - + (** [set0 p x] constructs the singleton trie that maps [p] to [x] and has no other bindings. *) - + Fixpoint set0 {A} (p: positive) (x: A) : tree' A := match p with | xH => Node010 x | xO q => Node100 (set0 q x) | xI q => Node001 (set0 q x) end. - + Fixpoint set' {A} (p: positive) (x: A) (m: tree' A) : tree' A := match p, m with | xH, Node001 r => Node011 x r @@ -143,18 +143,18 @@ Module PTree. | xI q, Node110 l y => Node111 l y (set0 q x) | xI q, Node111 l y r => Node111 l y (set' q x r) end. - + Definition set {A} (p: positive) (x: A) (m: tree A) : tree A := match m with | Empty => Nodes (set0 p x) | Nodes m' => Nodes (set' p x m') end. - + (** Removal in a nonempty trie produces a possibly empty trie. To simplify the code, we use the [Node] smart constructor in the cases where the result can be empty or nonempty, depending on the results of the recursive calls. *) - + Fixpoint rem' {A} (p: positive) (m: tree' A) : tree A := match p, m with | xH, Node001 r => Nodes m @@ -179,33 +179,33 @@ Module PTree. | xI q, Node110 l y => Nodes m | xI q, Node111 l y r => Node (Nodes l) (Some y) (rem' q r) end. - + (** This use of [Node] causes some run-time overhead, which we eliminate by asking Coq to unfold the definition of [Node] in [rem'], then simplify the definition. This is a form of partial evaluation. *) - + Definition remove' := Eval cbv [rem' Node] in @rem'. - + Definition remove {A} (p: positive) (m: tree A) : tree A := match m with | Empty => Empty | Nodes m' => remove' p m' end. - + (** ** Good variable properties for the basic operations *) - + Theorem gempty: forall (A: Type) (i: positive), get i (empty A) = None. Proof. reflexivity. Qed. - + Lemma gss0: forall {A} p (x: A), get' p (set0 p x) = Some x. Proof. induction p; simpl; auto. Qed. - + Lemma gso0: forall {A} p q (x: A), p<>q -> get' p (set0 q x) = None. Proof. induction p; destruct q; simpl; intros; auto; try apply IHp; congruence. Qed. - + Theorem gss: forall (A: Type) (i: positive) (x: A) (m: tree A), get i (set i x m) = Some x. Proof. @@ -213,7 +213,7 @@ Module PTree. - apply gss0. - revert m; induction i; destruct m; simpl; intros; auto using gss0. Qed. - + Theorem gso: forall (A: Type) (i j: positive) (x: A) (m: tree A), i <> j -> get i (set j x m) = get i m. @@ -223,14 +223,14 @@ Module PTree. - revert m j H; induction i; destruct j,m; simpl; intros; auto; solve [apply IHi; congruence | apply gso0; congruence | congruence]. Qed. - + Lemma gNode: forall {A} (i: positive) (l: tree A) (x: option A) (r: tree A), get i (Node l x r) = match i with xH => x | xO j => get j l | xI j => get j r end. Proof. intros. destruct l, x, r; simpl; auto; destruct i; auto. Qed. - + Theorem grs: forall (A: Type) (i: positive) (m: tree A), get i (remove i m) = None. Proof. @@ -239,7 +239,7 @@ Module PTree. change (remove' i m) with (rem' i m). revert m. induction i; destruct m; simpl; auto; rewrite gNode; auto. Qed. - + Theorem gro: forall (A: Type) (i j: positive) (m: tree A), i <> j -> get i (remove j m) = get i m. @@ -251,16 +251,16 @@ Module PTree. solve [ congruence | rewrite gNode; auto; apply IHi; congruence ]. Qed. - + (** ** The [map_filter] collective operation over tries *) - + Section MAP_FILTER. - + Variables A B: Type. - + Definition option_map (f: A -> option B) (o: option A): option B := match o with None => None | Some a => f a end. - + Fixpoint map_filter' (f: A -> option B) (m: tree' A) : tree B := match m with | Node001 r => Node Empty None (map_filter' f r) @@ -271,22 +271,22 @@ Module PTree. | Node110 l x => Node (map_filter' f l) (f x) Empty | Node111 l x r => Node (map_filter' f l) (f x) (map_filter' f r) end. - + Definition map_filter'_opt := Eval cbv [map_filter' Node] in map_filter'. - + Definition map_filter (f: A -> option B) (m: tree A) : tree B := match m with | Empty => Empty | Nodes m' => map_filter'_opt f m' end. - + Theorem gmap_filter': forall (f: A -> option B) (m: tree' A) (i: positive), get i (map_filter' f m) = option_map f (get' i m). Proof using Type. induction m; simpl; intros; rewrite gNode; destruct i; simpl; auto. Qed. - + Theorem gmap_filter: forall (f: A -> option B) (m: tree A) (i: positive), get i (map_filter f m) = option_map f (get i m). @@ -295,7 +295,7 @@ Module PTree. change (map_filter'_opt f m) with (map_filter' f m). apply gmap_filter'. Qed. - + Lemma unroll_map_filter: forall (f: A -> option B) (l: tree A) (o: option A) (r: tree A), map_filter f (Node l o r) = Node (map_filter f l) (option_map f o) (map_filter f r). @@ -303,39 +303,39 @@ Module PTree. intros. unfold map_filter. change map_filter'_opt with map_filter'. destruct l, o, r; reflexivity. Qed. - + End MAP_FILTER. - + (** ** Custom case analysis principles and induction principles *) - + (** We can view canonical tries as being of one of two (non-exclusive) cases: either [Empty] for an empty trie, or [Node l o r] for a possibly nonempty trie, with [l] and [r] the left and right subtrees and [o] an optional value. These are exactly the two cases of the original implementation of tries (module [Original]). - + The [Empty] constructor and the [Node] smart function defined above provide one half of the view: the one that lets us construct values of type [tree A]. - + We now define the other half of the view: the one that lets us inspect and recurse over values of type [tree A]. This is achieved by defining appropriate principles for case analysis and induction. *) - + Definition not_trivially_empty {A} (l: tree A) (o: option A) (r: tree A) := match l, o, r with | Empty, None, Empty => False | _, _, _ => True end. - + (** *** A case analysis principle *) - + Section TREE_CASE. - + Context {A B: Type} (empty: B) (node: tree A -> option A -> tree A -> B). - + Definition tree_case (m: tree A) : B := match m with | Empty => empty @@ -347,7 +347,7 @@ Module PTree. | Nodes (Node110 l x) => node (Nodes l) (Some x) Empty | Nodes (Node111 l x r) => node (Nodes l) (Some x) (Nodes r) end. - + (** In terms of the original implementation of tries, the function [tree_case] corresponds to a simple pattern matching: << @@ -355,35 +355,35 @@ Module PTree. match m with Leaf => empty | Node l o r => node l o r end. >> *) - + Lemma unroll_tree_case: forall l o r, not_trivially_empty l o r -> tree_case (Node l o r) = node l o r. Proof using Type. destruct l, o, r; simpl; intros; auto. contradiction. Qed. - + (** Alternatively, we can omit the [not_trivially_empty] hypothesis if the [node] case for trivially empty nodes agrees with the [empty] case. *) - + Hypothesis node_empty: node Empty None Empty = empty. - + Lemma unroll_tree_case_gen: forall l o r, tree_case (Node l o r) = node l o r. Proof using A B empty node node_empty. destruct l, o, r; simpl; auto. Qed. - + End TREE_CASE. - + (** *** A recursion principle *) - + Section TREE_REC. - + Context {A B: Type} (empty: B) (node: tree A -> B -> option A -> tree A -> B -> B). - + Fixpoint tree_rec' (m: tree' A) : B := match m with | Node001 r => node Empty empty None (Nodes r) (tree_rec' r) @@ -394,13 +394,13 @@ Module PTree. | Node110 l x => node (Nodes l) (tree_rec' l) (Some x) Empty empty | Node111 l x r => node (Nodes l) (tree_rec' l) (Some x) (Nodes r) (tree_rec' r) end. - + Definition tree_rec (m: tree A) : B := match m with | Empty => empty | Nodes m' => tree_rec' m' end. - + (** In terms of the original implementation of tries, the function [tree_rec] corresponds to the basic recursion principle for type [Original.tree]: @@ -412,37 +412,37 @@ Module PTree. end. >> *) - + Lemma unroll_tree_rec: forall l o r, not_trivially_empty l o r -> tree_rec (Node l o r) = node l (tree_rec l) o r (tree_rec r). Proof using Type. destruct l, o, r; simpl; intros; auto. contradiction. Qed. - + Hypothesis node_empty: node Empty empty None Empty empty = empty. - + Lemma unroll_tree_rec_gen: forall l o r, tree_rec (Node l o r) = node l (tree_rec l) o r (tree_rec r). Proof using A B empty node node_empty. destruct l, o, r; simpl; auto. Qed. - + End TREE_REC. - + (** *** An induction principle *) - + (** We now define a more general induction principle that supports a result type that depends on the argument value. This principle is usable both for computations and for proofs. *) - + Section TREE_IND. - + Context {A: Type} (P: tree A -> Type) (empty: P Empty) (node: forall l, P l -> forall o r, P r -> not_trivially_empty l o r -> P (Node l o r)). - + Program Fixpoint tree_ind' (m: tree' A) : P (Nodes m) := match m with | Node001 r => @node Empty empty None (Nodes r) (tree_ind' r) _ @@ -453,24 +453,24 @@ Module PTree. | Node110 l x => @node (Nodes l) (tree_ind' l) (Some x) Empty empty _ | Node111 l x r => @node (Nodes l) (tree_ind' l) (Some x) (Nodes r) (tree_ind' r) _ end. - + Definition tree_ind (m: tree A) : P m := match m with | Empty => empty | Nodes m' => tree_ind' m' end. - + (** [tree_ind] defined above has almost the same type as the induction principle automatically derived by Coq for the [Original.tree] type of the original trie implementation. The only difference is that the [node] case receives an additional hypothesis [not_trivially_empty l o r], which is useful to apply the [unroll_tree_case] and [unroll_tree_rec] equations. *) - + End TREE_IND. - + (** Example of use: alternate proofs for the [set] operation. *) - + Lemma set_Empty: forall A (v: A) p, set p v Empty = match p with @@ -481,7 +481,7 @@ Module PTree. Proof. destruct p; reflexivity. Qed. - + Lemma set_Node: forall A (v: A) l o r p, set p v (Node l o r) = match p with @@ -492,14 +492,14 @@ Module PTree. Proof. destruct l, o, r, p; reflexivity. Qed. - + Theorem gss_alt_proof: forall (A: Type) (i: positive) (x: A) (m: tree A), get i (set i x m) = Some x. Proof. induction i; induction m using tree_ind; intros; (rewrite set_Empty || rewrite set_Node); rewrite gNode; auto. Qed. - + Theorem gso_alt_proof: forall (A: Type) (i j: positive) (x: A) (m: tree A), i <> j -> get i (set j x m) = get i m. @@ -508,20 +508,20 @@ Module PTree. (rewrite set_Empty || rewrite set_Node); rewrite ! gNode; auto; try (apply IHi); congruence. Qed. - + (** ** The [combine] collective operation over pairs of tries *) - + Section COMBINE. - + Variables A B C: Type. Variable f: option A -> option B -> option C. Hypothesis f_None_None: f None None = None. - + Definition combine'_l := map_filter' (fun a => f (Some a) None). Definition combine'_r := map_filter' (fun b => f None (Some b)). - + (** First definition of [combine'], done by writing 49 cases (7x7) by hand. *) - + Fixpoint combine'_direct (m1: tree' A) (m2: tree' B) {struct m1} : tree C := let c := combine'_direct in let f1 x1 := f (Some x1) None in @@ -537,7 +537,7 @@ Module PTree. | Node001 r1, Node101 l2 r2 => Node (c2 l2) None (c r1 r2) | Node001 r1, Node110 l2 x2 => Node (c2 l2) (f2 x2) (c1 r1) | Node001 r1, Node111 l2 x2 r2 => Node (c2 l2) (f2 x2) (c r1 r2) - + | Node010 x1, Node001 r2 => Node Empty (f1 x1) (c2 r2) | Node010 x1, Node010 x2 => Node Empty (f' x1 x2) Empty | Node010 x1, Node011 x2 r2 => Node Empty (f' x1 x2) (c2 r2) @@ -545,7 +545,7 @@ Module PTree. | Node010 x1, Node101 l2 r2 => Node (c2 l2) (f1 x1) (c2 r2) | Node010 x1, Node110 l2 x2 => Node (c2 l2) (f' x1 x2) Empty | Node010 x1, Node111 l2 x2 r2 => Node (c2 l2) (f' x1 x2) (c2 r2) - + | Node011 x1 r1, Node001 r2 => Node Empty (f1 x1) (c r1 r2) | Node011 x1 r1, Node010 x2 => Node Empty (f' x1 x2) (c1 r1) | Node011 x1 r1, Node011 x2 r2 => Node Empty (f' x1 x2) (c r1 r2) @@ -553,7 +553,7 @@ Module PTree. | Node011 x1 r1, Node101 l2 r2 => Node (c2 l2) (f1 x1) (c r1 r2) | Node011 x1 r1, Node110 l2 x2 => Node (c2 l2) (f' x1 x2) (c1 r1) | Node011 x1 r1, Node111 l2 x2 r2 => Node (c2 l2) (f' x1 x2) (c r1 r2) - + | Node100 l1, Node001 r2 => Node (c1 l1) None (c2 r2) | Node100 l1, Node010 x2 => Node (c1 l1) (f2 x2) Empty | Node100 l1, Node011 x2 r2 => Node (c1 l1) (f2 x2) (c2 r2) @@ -561,7 +561,7 @@ Module PTree. | Node100 l1, Node101 l2 r2 => Node (c l1 l2) None (c2 r2) | Node100 l1, Node110 l2 x2 => Node (c l1 l2) (f2 x2) Empty | Node100 l1, Node111 l2 x2 r2 => Node (c l1 l2) (f2 x2) (c2 r2) - + | Node101 l1 r1, Node001 r2 => Node (c1 l1) None (c r1 r2) | Node101 l1 r1, Node010 x2 => Node (c1 l1) (f2 x2) (c1 r1) | Node101 l1 r1, Node011 x2 r2 => Node (c1 l1) (f2 x2) (c r1 r2) @@ -569,7 +569,7 @@ Module PTree. | Node101 l1 r1, Node101 l2 r2 => Node (c l1 l2) None (c r1 r2) | Node101 l1 r1, Node110 l2 x2 => Node (c l1 l2) (f2 x2) (c1 r1) | Node101 l1 r1, Node111 l2 x2 r2 => Node (c l1 l2) (f2 x2) (c r1 r2) - + | Node110 l1 x1, Node001 r2 => Node (c1 l1) (f1 x1) (c2 r2) | Node110 l1 x1, Node010 x2 => Node (c1 l1) (f' x1 x2) Empty | Node110 l1 x1, Node011 x2 r2 => Node (c1 l1) (f' x1 x2) (c2 r2) @@ -577,7 +577,7 @@ Module PTree. | Node110 l1 x1, Node101 l2 r2 => Node (c l1 l2) (f1 x1) (c2 r2) | Node110 l1 x1, Node110 l2 x2 => Node (c l1 l2) (f' x1 x2) Empty | Node110 l1 x1, Node111 l2 x2 r2 => Node (c l1 l2) (f' x1 x2) (c2 r2) - + | Node111 l1 x1 r1, Node001 r2 => Node (c1 l1) (f1 x1) (c r1 r2) | Node111 l1 x1 r1, Node010 x2 => Node (c1 l1) (f' x1 x2) (c1 r1) | Node111 l1 x1 r1, Node011 x2 r2 => Node (c1 l1) (f' x1 x2) (c r1 r2) @@ -586,29 +586,29 @@ Module PTree. | Node111 l1 x1 r1, Node110 l2 x2 => Node (c l1 l2) (f' x1 x2) (c1 r1) | Node111 l1 x1 r1, Node111 l2 x2 r2 => Node (c l1 l2) (f' x1 x2) (c r1 r2) end. - + (** We now prove the expected "get-combine" equation for [combine'_direct]. This is a great way to find mistakes in the definition above. *) - + Lemma gcombine'_l: forall m i, get i (combine'_l m) = f (get' i m) None. Proof using A B C f f_None_None. intros. unfold combine'_l. rewrite gmap_filter'. destruct (get' i m); auto. Qed. - + Lemma gcombine'_r: forall m i, get i (combine'_r m) = f None (get' i m). Proof using A B C f f_None_None. intros. unfold combine'_r. rewrite gmap_filter'. destruct (get' i m); auto. Qed. - + Lemma gcombine'_direct: forall m1 m2 i, get i (combine'_direct m1 m2) = f (get' i m1) (get' i m2). Proof using A B C f f_None_None. induction m1; destruct m2; intros; simpl; rewrite gNode; destruct i; simpl; auto using gcombine'_l, gcombine'_r. Qed. - + (** Second definition of [combine'], using tactics to fill out the 49 cases. *) - + Fixpoint combine'_by_tac (m1: tree' A) (m2: tree' B) {struct m1} : tree C. Proof using A B C f. destruct m1 as [ r1 | x1 | x1 r1 | l1 | l1 r1 | l1 x1 | l1 x1 r1 ]; @@ -628,31 +628,31 @@ Module PTree. | exact Empty ] ]). Defined. - + (** Again, proving the "get-combine" equation for [combine'_by_tac] brings much confidence that we got the tactics-based definition right. The proof script is identical to the proof for [gcombine'_direct], which is not surprising in light of the Lemma [combine'_by_tac_eq], below! *) - + Lemma gcombine'_by_tac: forall m1 m2 i, get i (combine'_by_tac m1 m2) = f (get' i m1) (get' i m2). Proof using A B C f f_None_None. induction m1; destruct m2; intros; simpl; rewrite gNode; destruct i; simpl; auto using gcombine'_l, gcombine'_r. Qed. - + (** Actually, the tactics produced exactly the same definition as the one we wrote by hand before. *) - + Lemma combine'_by_tac_eq: combine'_by_tac = combine'_direct. Proof using Type. reflexivity. Qed. - + (** We can now finish the definition of [combine], adding cases for when one or both of the tries are empty. *) - + Definition combine (m1: tree A) (m2: tree B) : tree C := match m1, m2 with | Empty, Empty => Empty @@ -660,7 +660,7 @@ Module PTree. | Nodes m1, Empty => combine'_l m1 | Nodes m1, Nodes m2 => combine'_by_tac m1 m2 end. - + Theorem gcombine: forall (m1: tree A) (m2: tree B) (i: positive), get i (combine m1 m2) = f (get i m1) (get i m2). @@ -671,11 +671,11 @@ Module PTree. - apply gcombine'_l. - apply gcombine'_by_tac. Qed. - + (** An alternate definition of [combine] is possible, using the 2-constructor view of tries and the custom induction principles introduced earlier. *) - + Definition combine_view_gen (m1: tree A) (m2: tree B) : tree C := tree_rec (map_filter (fun b => f None (Some b))) @@ -684,17 +684,17 @@ Module PTree. (map_filter (fun a => f (Some a) None) (Node l1 o1 r1)) (fun l2 o2 r2 => Node (lrec l2) (f o1 o2) (rrec r2))) m1 m2. - + (** The custom principles add a lot of run-time overhead. Partial evaluation can eliminate most (but not all) of this overhead. *) - + Definition combine_view := Eval cbv [combine_view_gen tree_rec tree_rec' tree_case] in combine_view_gen. - + (** The combine equation can be proved directly on the [combine_view] implementation, using [tree_ind] to perform induction on [m1] and case analysis on [m2]. *) - + Theorem gcombine_view: forall (m1: tree A) (m2: tree B) (i: positive), get i (combine_view m1 m2) = f (get i m1) (get i m2). @@ -702,19 +702,19 @@ Module PTree. change combine_view with combine_view_gen. unfold combine_view_gen. induction m1 using tree_ind; intros. - simpl. rewrite gmap_filter. destruct (get i m2); auto. - - rewrite unroll_tree_rec by auto. + - rewrite unroll_tree_rec by auto. induction m2 using tree_ind; intros. + simpl. rewrite gmap_filter. destruct (get i (Node m1_1 o m1_2)); auto. + rewrite unroll_tree_case by auto. rewrite ! gNode. destruct i; auto. Qed. - + End COMBINE. - + (** ** Extensionality property *) - + (** This is the key property of canonical tries that makes them extensional: every [tree' A] contains at least one key-value pair. *) - + Lemma tree'_not_empty: forall (A: Type) (m: tree' A), exists i, get' i m <> None. Proof. @@ -727,10 +727,10 @@ Module PTree. - exists xH; simpl; congruence. - exists xH; simpl; congruence. Qed. - + (** As a corollary, the only [tree A] that contains no key-value pairs is [Empty]. *) - + Corollary extensionality_empty: forall (A: Type) (m: tree A), (forall i, get i m = None) -> m = Empty. @@ -738,11 +738,11 @@ Module PTree. intros. destruct m as [ | m]; auto. destruct (tree'_not_empty m) as [i GET]. elim GET. apply H. Qed. - + (** Extensionality follows by a simple inductive argument. We can use [tree_ind] as the induction principle so as to reduce the number of cases to consider to 4. *) - + Theorem extensionality: forall (A: Type) (m1 m2: tree A), (forall i, get i m1 = get i m2) -> m1 = m2. @@ -756,5 +756,5 @@ Module PTree. + specialize (H1 xH); rewrite ! gNode in H1. auto. + apply IHm1_2. intros. specialize (H1 (xI i)); rewrite ! gNode in H1. auto. Qed. - + End PTree. diff --git a/template-coq/theories/utils/wGraph.v b/template-coq/theories/utils/wGraph.v index 455baff60..6361df120 100644 --- a/template-coq/theories/utils/wGraph.v +++ b/template-coq/theories/utils/wGraph.v @@ -262,7 +262,7 @@ Module Nbar. Proof. destruct m; cbn; lia. Qed. - + Lemma le_antisymm {n m} : n <= m -> m <= n -> n = m. Proof. destruct n, m; cbn; try easy. @@ -282,26 +282,26 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module (** Lemmas on sets *) - Lemma VSet_add_remove x y p : + Lemma VSet_add_remove x y p : x <> y -> VSet.Equal (VSet.add x (VSet.remove y p)) (VSet.remove y (VSet.add x p)). Proof. now sets. Qed. - Lemma VSet_remove_add x p : + Lemma VSet_remove_add x p : ~ VSet.In x p -> VSet.Equal (VSet.remove x (VSet.add x p)) p. Proof. now sets. Qed. - Lemma VSet_add_add x y p : + Lemma VSet_add_add x y p : VSet.Equal (VSet.add x (VSet.add y p)) (VSet.add y (VSet.add x p)). Proof. now sets. Qed. - Lemma VSet_add_add_same x p : + Lemma VSet_add_add_same x p : VSet.Equal (VSet.add x (VSet.add x p)) (VSet.add x p). Proof. now sets. Qed. - Definition Disjoint s s' := + Definition Disjoint s s' := VSet.Empty (VSet.inter s s'). Definition DisjointAdd x s s' := VSetProp.Add x s s' /\ ~ VSet.In x s. @@ -387,7 +387,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module + eapply VSetFact.remove_3; eassumption. - now apply VSetFact.remove_1. Qed. - + Global Instance Add_Proper : Proper (eq ==> VSet.Equal ==> VSet.Equal ==> iff) VSetProp.Add. Proof. @@ -415,8 +415,8 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module apply Add_In, H. left; reflexivity. Qed. - Lemma Disjoint_DisjointAdd x s s' s'' : - DisjointAdd x s s' -> + Lemma Disjoint_DisjointAdd x s s' s'' : + DisjointAdd x s s' -> Disjoint s' s'' -> Disjoint s s''. Proof. @@ -437,7 +437,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Lemma DisjointAdd_Equal_l x s s' s'' : DisjointAdd x s s' -> VSet.Equal s s'' -> DisjointAdd x s'' s'. Proof. now intros d <-. Qed. - Lemma DisjointAdd_remove_inv {x s s' z} : DisjointAdd x s (VSet.remove z s') -> + Lemma DisjointAdd_remove_inv {x s s' z} : DisjointAdd x s (VSet.remove z s') -> VSet.Equal s (VSet.remove z s). Proof. intros []. @@ -505,7 +505,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module end. Definition eq_leibniz : forall x y, eq x y -> x = y := fun x y eq => eq. - + End Edge. Module EdgeSet:= MSetAVL.Make Edge. Module EdgeSetFact := WFactsOn Edge EdgeSet. @@ -538,7 +538,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module (VSet.add x (V G), (E G), (s G)). Definition add_edge e : t := - (VSet.add e..s (VSet.add e..t (V G)), + (VSet.add e..s (VSet.add e..t (V G)), EdgeSet.add e (E G), (s G)). Definition EdgeOf x y := ∑ n, EdgeSet.In (x, n, y) (E G). @@ -630,7 +630,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Proof using Type. induction p; cbn; lia. Qed. - + Fixpoint is_simple {x y} (p : PathOf x y) := match p with | pathOf_refl x => true @@ -724,7 +724,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Qed. Obligation Tactic := Program.Tactics.program_simpl. - Program Fixpoint sconcat {s s' x y z} (p : SPath s x y) : Disjoint s s' -> + Program Fixpoint sconcat {s s' x y z} (p : SPath s x y) : Disjoint s s' -> SPath s' y z -> SPath (VSet.union s s') x z := match p in SPath s x y return Disjoint s s' -> SPath s' y z -> SPath (VSet.union s s') x z with | spath_refl _ _ => fun hin q => SPath_sub _ q @@ -732,7 +732,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module @spath_step (VSet.union s s') _ x y z _ e (@sconcat _ _ _ _ _ p _ q) end. Next Obligation. sets. Qed. - Next Obligation. + Next Obligation. eapply DisjointAdd_union; eauto. destruct da. unfold Disjoint in hin. intros inxs'. apply (hin x). @@ -760,7 +760,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Definition split {s x y} (p : SPath s x y) - : forall u, {VSet.In u (snodes p)} + {u = y} -> + : forall u, {VSet.In u (snodes p)} + {u = y} -> SPath (VSet.remove u s) x u * SPath s u y. Proof. induction p; intros u Hu; cbn in *. @@ -825,7 +825,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module : sweight (split' p).1 + sweight (split' p).2 = sweight p. Proof. unfold split'; apply weight_split. - Defined. + Defined. Definition spath_one {s x y k} (Hx : VSet.In x s) (Hk : EdgeSet.In (x, k, y) (E G)) : SPath s x y. @@ -973,7 +973,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module | true => let s := VSet.remove x s in EdgeSet.fold - (fun '(src, w, tgt) acc => + (fun '(src, w, tgt) acc => if V.eq_dec src x then Nbar.max acc (Some w + lsp00_fast fuel s tgt z) else acc)%nbar @@ -981,18 +981,18 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module | false => base end end. - Lemma fold_left_map {A B C} (f : A -> B -> A) (g : C -> B) l acc : fold_left f (map g l) acc = + Lemma fold_left_map {A B C} (f : A -> B -> A) (g : C -> B) l acc : fold_left f (map g l) acc = fold_left (fun acc x => f acc (g x)) l acc. Proof. induction l in acc |- *; cbn; auto. - Qed. + Qed. - Lemma fold_left_filter {A B} (f : A -> B -> A) (g : B -> bool) l acc : fold_left f (filter g l) acc = + Lemma fold_left_filter {A B} (f : A -> B -> A) (g : B -> bool) l acc : fold_left f (filter g l) acc = fold_left (fun acc x => if g x then f acc x else acc) l acc. Proof. induction l in acc |- *; cbn; auto. destruct (g a) => //=. - Qed. + Qed. #[global] Instance fold_left_proper {A B} : Proper (`=2` ==> `=2`) (@fold_left A B). Proof. @@ -1001,7 +1001,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module cbn. rewrite (hfg acc a). apply IHx. Qed. - Lemma fold_left_equiv {A B C} (f : A -> B -> A) (g : A -> C -> A) (h : C -> B) l l' acc : + Lemma fold_left_equiv {A B C} (f : A -> B -> A) (g : A -> C -> A) (h : C -> B) l l' acc : (forall acc x, f acc (h x) = g acc x) -> l = map h l' -> fold_left f l acc = fold_left g l' acc. @@ -1010,7 +1010,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module induction l' in acc |- *; cbn; auto. rewrite fold_left_map. rewrite hfg. apply fold_left_proper. exact hfg. - Qed. + Qed. Lemma lsp00_optim fuel s x z : lsp00_fast fuel s x z = lsp00 fuel s x z. Proof. @@ -1196,10 +1196,10 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module now apply DisjointAdd_remove1. Qed. - Definition is_nonpos n := + Definition is_nonpos n := match n with | Some z => (z <=? 0) - | None => false + | None => false end. Lemma is_nonpos_spec n : is_nonpos n <-> exists z, n = Some z /\ z <= 0. @@ -1322,7 +1322,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Lemma lsp_s {HG : acyclic_no_loop} x (Hx : VSet.In x (V G)) : exists n, lsp (s G) x = Some n /\ 0 <= n. - Proof using G HI. + Proof using G HI. case_eq (lsp (s G) x). - intros n H; eexists; split; [reflexivity|]. destruct (source_pathOf _ Hx) as [[p [w]]]. @@ -1336,7 +1336,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module pose proof (lsp0_spec_le (simplify2' p)) as X. unfold lsp in e; rewrite e in X. inversion X. Qed. - + Lemma SPath_In {s x y} (p : SPath s x y) : sweight p <> 0 -> VSet.In x s. Proof using Type. @@ -1379,16 +1379,16 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module | _ => 0%nat end. - Lemma Z_of_to_label (z : Z) : + Lemma Z_of_to_label (z : Z) : Z.of_nat (to_label (Some z)) = if 0 <=? z then z else 0. Proof using Type. simpl. destruct z; auto. simpl. apply Z_of_pos_alt. Qed. - Lemma Z_of_to_label_s {HG : acyclic_no_loop} x : + Lemma Z_of_to_label_s {HG : acyclic_no_loop} x : VSet.In x (V G) -> - exists n, lsp (s G) x = Some n /\ + exists n, lsp (s G) x = Some n /\ 0 <= n /\ (Z.of_nat (to_label (lsp (s G) x))) = n. Proof using G HI. intros inx. @@ -1431,13 +1431,13 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module cbn in H; erewrite Hp1, Hp2 in H. simpl. etransitivity; eauto. simpl. eauto. Qed. - + (* The two largest simple pathOf between nodes in both directions bound each other. *) - Lemma lsp_sym {HG : acyclic_no_loop} {x y n} : + Lemma lsp_sym {HG : acyclic_no_loop} {x y n} : lsp x y = Some n -> (lsp y x <= Some (-n))%nbar. Proof using Type. - intros Hn. + intros Hn. destruct (lsp0_spec_eq _ Hn) as [p Hp]. destruct (lsp y x) eqn:lspyx. 2:simpl; auto. @@ -1457,7 +1457,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module lia. Qed. - Lemma le_Some_lsp {n x y} : (Some n <= lsp x y)%nbar -> + Lemma le_Some_lsp {n x y} : (Some n <= lsp x y)%nbar -> exists k, lsp x y = Some k /\ n <= k. Proof using Type. destruct lsp eqn:xy. @@ -1465,7 +1465,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module simpl; now intros []. Qed. - (* There can be no universe lower than the source: all pathOf to the source have null or + (* There can be no universe lower than the source: all pathOf to the source have null or negative weight. *) Lemma source_bottom {HG : acyclic_no_loop} {x} (p : PathOf x (s G)) : weight p <= 0. Proof using HI. @@ -1647,7 +1647,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module now simpl. Qed. - Lemma is_acyclic_correct : reflectProp acyclic_no_loop is_acyclic. + Lemma is_acyclic_correct : reflectProp acyclic_no_loop is_acyclic. Proof using HI. eapply reflect_reflectProp, reflect_logically_equiv. eapply acyclic_caract2. @@ -1663,12 +1663,12 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Arguments sweight {G s x y}. Arguments weight {G x y}. - Module Subgraph1. + Module Subgraph1. Section graph2. Context (G : t) {HI : invariants G} {HG : acyclic_no_loop G}. Context (y_0 x_0 : V.t) (Vx : VSet.In x_0 (V G)) (Vy : VSet.In y_0 (V G)) - (K : Z) + (K : Z) (Hxs : lsp G x_0 y_0 = Some K). Local Definition G' : t @@ -1717,7 +1717,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Lemma from_G'_path_weight {u v} (q : PathOf G' u v) : match from_G'_path q with | inl q' => weight q = weight q' - | inr (q1, q2) => + | inr (q1, q2) => weight q <= weight q1 - K + weight q2 end. Proof using HG HI Hxs. @@ -1727,7 +1727,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module - simpl. destruct (Edge.eq_dec (y_0, - K, x_0) (x, e.π1, y)) as [XX|XX]; simpl. + destruct (fst_eq (fst_eq XX)). simpl. - inversion XX. + inversion XX. destruct (from_G'_path q) as [q'|[q1 q2]]; simpl. * destruct (snd_eq XX); cbn. destruct e as [e He]; cbn in *. lia. @@ -1919,7 +1919,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Section subgraph2. Context (y_0 x_0 : V.t) (Vx : VSet.In x_0 (V G)) (Vy : VSet.In y_0 (V G)) - (Hxs : lsp G x_0 y_0 = None) + (Hxs : lsp G x_0 y_0 = None) (K : Z). Local Definition G' : t @@ -1978,7 +1978,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module - simpl. destruct (Edge.eq_dec (y_0, K, x_0) (x, e.π1, y)) as [XX|XX]; simpl. + destruct (fst_eq (fst_eq XX)). simpl. - inversion XX. + inversion XX. destruct (from_G'_path q) as [q'|[q1 q2]]; simpl. * destruct (snd_eq XX); cbn. destruct e as [e He]; cbn in *. lia. @@ -2184,7 +2184,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Arguments pathOf_refl {G x}. Arguments pathOf_step {G x y z}. - + Fixpoint PathOf_add_end {x y z} (p : PathOf G x y) : EdgeOf G y z -> PathOf G x z := match p with | pathOf_refl => fun e => pathOf_step e pathOf_refl @@ -2204,8 +2204,8 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module destruct b; simpl; auto. Qed. - Lemma In_nodes_app_end {x y z} (p : PathOf G x y) (e : EdgeOf G y z) i : - VSet.In i (nodes G (PathOf_add_end p e)) -> + Lemma In_nodes_app_end {x y z} (p : PathOf G x y) (e : EdgeOf G y z) i : + VSet.In i (nodes G (PathOf_add_end p e)) -> VSet.In i (nodes G p) \/ i = y. Proof using HI. induction p; simpl; try sets. @@ -2215,7 +2215,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module - specialize (IHp _ H). sets. Qed. - Lemma pathOf_add_end_simpl {x y z} (p : PathOf G x y) (e : EdgeOf G y z) : + Lemma pathOf_add_end_simpl {x y z} (p : PathOf G x y) (e : EdgeOf G y z) : is_simple _ p -> ~~ VSet.mem y (nodes G p) -> is_simple _ (PathOf_add_end p e). Proof using HI. induction p; simpl; auto. @@ -2223,7 +2223,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module move/andP => [nmen iss]. specialize (IHp e iss). intros Hm%negbe. rewrite andb_and. split; auto. - apply negbe. intro. + apply negbe. intro. apply VSet.mem_spec in H. apply Hm. eapply In_nodes_app_end in H as [inn | ->]. eapply negbe in nmen. now elim nmen; apply VSet.mem_spec. @@ -2294,7 +2294,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module subst yx. pose proof (lsp_codistance G' (s G) y x). rewrite Hky' lspyx Hkx' in H1. simpl in H1. lia. - + + pose (K := if n <=? 0 then Z.max lx (Z.succ ly - n) else Z.max lx (Z.succ ly)). unshelve epose proof (correct_labelling_lsp_G' _ _ _ _ xs K) as XX; tas; try apply HI. @@ -2328,8 +2328,8 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module * intro X; rewrite X in Hle; inversion Hle. Defined. - Lemma lsp_vset_in {s x y n} : - lsp0 G s x y = Some n -> + Lemma lsp_vset_in {s x y n} : + lsp0 G s x y = Some n -> (n = 0 /\ x = y) \/ (VSet.In y (V G)). Proof using HI. intros H. @@ -2347,7 +2347,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module case_eq (VSet.mem y (V G)); intro Vy; [apply VSet.mem_spec in Vy; now apply leq_vertices_caract0|]. split. - - intro Hle. apply VSetFact.not_mem_iff in Vy. + - intro Hle. apply VSetFact.not_mem_iff in Vy. assert (nneg : n <= 0). { pose (K := to_label (lsp G (s G) x)). pose (l := fun z => if V.eq_dec z y then K @@ -2371,12 +2371,12 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module case_eq (lsp G x (s G)); [intros; cbn; try lia|]. ++ destruct (VSet.mem x (V G)) eqn:mem. 2:{ enough (z = 0); try lia. - epose proof (lsp0_spec_eq G _ H) as [p wp]. - assert (~ VSet.In x (V G)). + epose proof (lsp0_spec_eq G _ H) as [p wp]. + assert (~ VSet.In x (V G)). { intros inx. eapply VSet.mem_spec in inx. congruence. } - clear - HI HG H0 p wp. + clear - HI HG H0 p wp. depind p. simpl in wp. lia. - epose proof (edges_vertices G). destruct e. + epose proof (edges_vertices G). destruct e. specialize (H _ i) as [H _]. cbn in H. contradiction. } apply VSet.mem_spec in mem. red in Hle. unshelve epose proof (Subgraph1.correct_labelling_lsp_G' G (s G) x mem _ _ H) as X. @@ -2410,7 +2410,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module rewrite Z_of_to_label_pos in Hle. lia. assert (lx = - z). { enough (lsp G' (s G') x = Some (- z)). congruence. - rewrite (Subgraph1.lsp_G'_spec_left G _ _ _ _ _ H x). auto. + rewrite (Subgraph1.lsp_G'_spec_left G _ _ _ _ _ H x). auto. apply source_vertex; eauto. rewrite lsp_xx /=. pose proof (lsp_s G x mem) as [lx' [lspx' w]]. @@ -2422,7 +2422,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module ++ intros Hxs. simpl. case_eq (VSet.mem x (V G)); intro Vx. * apply VSet.mem_spec in Vx. - assert (x <> s G). + assert (x <> s G). { destruct (V.eq_dec x (s G)) => //. rewrite e in Hxs. epose proof (lsp0_spec_le G (spath_refl G (V G) (s G))). rewrite /lsp in Hxs. now rewrite Hxs in H. } @@ -2500,7 +2500,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module simpl in Hxs. rewrite <- sweight_weight, Hp in H. lia. Defined. - + Definition leqb_vertices z x y : bool := if VSet.mem y (V G) then if is_left (Nbar.le_dec (Some z) (lsp_fast G x y)) then true else false else (Z.leb z 0 && (V.eq_dec x y || Nbar.le_dec (Some z) (lsp_fast G x (s G))))%bool. @@ -2508,7 +2508,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Lemma leqb_vertices_correct n x y : leq_vertices G n x y <-> leqb_vertices n x y. Proof using HG HI. - etransitivity. apply leq_vertices_caract. + etransitivity. apply leq_vertices_caract. rewrite /leqb_vertices !lsp_optim. destruct (VSet.mem y (V G)). - destruct (le_dec (Some n) (lsp G x y)); cbn; intuition. @@ -2546,17 +2546,17 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Qed. Definition diff (l : labelling) x y := Z.of_nat (l y) - Z.of_nat (l x). - + Definition relabel (G : t) (l : labelling) : t := (V G, edge_map (fun e => (e..s , diff l e..s e..t, e..t)) (E G), s G). Lemma relabel_weight G l (Gl := relabel G l) : forall x y (p : PathOf Gl x y), weight p = Z.of_nat (l y) - Z.of_nat (l x). Proof. - move=> x y; elim => [?/=|??? [? /= /edge_map_spec2 [?[[=]????]]] ? ->]. + move=> x y; elim => [?/=|??? [? /= /edge_map_spec2 [?[[=]????]]] ? ->]. 2: subst; unfold diff. all: lia. - Qed. + Qed. Lemma relabel_lsp G l (Gl := relabel G l) : forall x y n, lsp Gl x y = Some n -> n = Z.of_nat (l y) - Z.of_nat (l x). @@ -2664,7 +2664,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module 1:move=> /(DisjointAdd_Subset disjadd) ?; apply/VSet.union_spec; by left. move=> /VSet.add_spec[->|?]; apply/VSet.union_spec; [left| by right]. apply: DisjointAdd_In; eassumption. - Qed. + Qed. Lemma reroot_spath_aux2 {x s0 s1 s2} : DisjointAdd x s1 s2 -> Disjoint s2 s0 -> @@ -2695,7 +2695,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Proof. elim: p=> {x z}[s0 x|s0 s1 x y' z disj01 e p ih] /=. - move=> /VSetFact.empty_iff []. - - case: (VSet.E.eq_dec y x)=> [->| neq]. + - case: (VSet.E.eq_dec y x)=> [->| neq]. * move=> _ s' q disj'; unshelve econstructor. + refine (sconcat G (spath_step G s0 s1 _ _ _ disj01 e p) disj' q). + rewrite sweight_sconcat //=. @@ -2888,7 +2888,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module apply: relabel_on_lsp_G1. apply: lsp_edge. Qed. - + Lemma weight_from2 [x y] (e : EdgeOf G2 x y) : (from2 e).π1 >= e.π1. Proof using H HGl. cbn; case E: (EdgeSet.mem _ _); last lia. @@ -2911,7 +2911,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module apply: weight_from2. Qed. - + Lemma sweight_relabel_on_G1 {s x y} (p : SPath Gl s x y) : VSet.In y (V G1) -> exists n, lsp G2 x (first_in G1 Gl p) = Some n /\ @@ -2968,7 +2968,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module * move: E0=> /EdgeSet.mem_spec /(edges_vertices G1 _) [sin ?] [] [=] ???. subst; exfalso; apply: (disj s). apply/VSet.inter_spec; split=> //; by apply: VSetFact.add_1. - * move=> [] [=] ??? e2; subst. + * move=> [] [=] ??? e2; subst. exact (lsp_edge G2 (w' ; e2)). + move=> v /VSet.inter_spec [??]; apply: (disj v). apply/VSet.inter_spec; split=> //. @@ -3063,7 +3063,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module pose proof (ub := lsp_Gl_upperbound_G1 _ _ xin yin _ Elsp). move=> /= ?; f_equal; lia. Qed. - + End RelabelOn. Record subgraph (G1 G2 : t) : Prop := { @@ -3129,7 +3129,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Definition add_from_orig v s := if VSet.mem v (V G1) then VSet.add v s else s. Definition fold_fun e s := add_from_orig (e..s) (add_from_orig (e..t) s). - + Definition border_set : VSet.t := EdgeSet.fold fold_fun ext VSet.empty. @@ -3138,7 +3138,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module transpose VSet.Equal f -> Proper (eq ==> VSet.Equal ==> VSet.Equal) f -> VSet.Equal (EdgeSet.fold f s i) (fold_right f i (EdgeSet.elements s)). - Proof using Type. + Proof using Type. move=> trf prpf; rewrite EdgeSet.fold_spec. elim: {s}(EdgeSet.elements s)=> // x l /= <-. elim: l i=> //= a l ih i. @@ -3153,12 +3153,12 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module unfold add_from_orig. move E: (VSet.mem _ _)=> []. - move: E=> /VSet.mem_spec ?; rewrite VSet.add_spec; intuition. - rewrite H0; left; intuition. + rewrite H0; left; intuition. - intuition; subst; exfalso. move: E=> /VSetFact.not_mem_iff; by apply. Qed. - Lemma fold_fun_spec x e s : + Lemma fold_fun_spec x e s : VSet.In x (fold_fun e s) <-> ((x = e..s \/ x = e..t) /\ VSet.In x (V G1)) \/ VSet.In x s. Proof using Type. @@ -3380,7 +3380,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Let Gl := relabel_on G1 G2 l. Let l' := to_label ∘ (lsp Gl (s Gl)). - + Lemma extends_labelling x : VSet.In x (V G1) -> l' x = l x. Proof using Gl H H0 HGl acG2 embed. move=> xin1. @@ -3415,7 +3415,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module epose (eGl (s, e'.π1, t) e'.π2). epose (weight_from2 G1 G2 l (edges_sub _ _ embed) HGl (w ; ein)). move: l0 g; cbn. lia. - Qed. + Qed. End ExtendLabelling. @@ -3431,7 +3431,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Context l (Hl : correct_labelling G l). Context x (k : nat) (d := Some (Z.of_nat (k + l x))) - (Hk : (lsp G x (s G) + d <= Some 0)%nbar). + (Hk : (lsp G x (s G) + d <= Some 0)%nbar). Definition r : labelling := fun z => Nat.max (l z) (to_label (lsp G x z + d)%nbar). @@ -3479,7 +3479,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module pose proof (lsp_codistance G x (s G) y). pose proof (lsp_codistance G (s G) x (s G)). case E: (lsp G x (s G)) H H0 => //. - rewrite ZifyInst.of_nat_to_nat_eq eqlspy eqlspx lsp_xx. + rewrite ZifyInst.of_nat_to_nat_eq eqlspy eqlspx lsp_xx. move: hxy. case: (lsp G x y)=> // ?. cbn. lia. Qed. @@ -3491,13 +3491,13 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module apply: r_correct; [apply: lsp_correctness | apply: dxy_bound]. Qed. - + Lemma to_label_add z k : (Some 0 <= z)%nbar -> (to_label z + k)%nat = to_label (z + Some (Z.of_nat k))%nbar. - Proof using Type. + Proof using Type. move: z=> [[|?|?]|] //=; case: k=> //=; lia. Qed. - Lemma to_label_mon z1 z2 : (z1 <= z2)%nbar -> (to_label z1 <= to_label z2)%nat. + Lemma to_label_mon z1 z2 : (z1 <= z2)%nbar -> (to_label z1 <= to_label z2)%nat. Proof using Type. move: z1 z2=> [[|?|?]|] [[|?|?]|] //=; lia. Qed. Lemma l'_on_x : l' x = (stdl x + dxy)%nat. diff --git a/test-suite/bugkncst.v b/test-suite/bugkncst.v index e00e73606..12bf4eeee 100644 --- a/test-suite/bugkncst.v +++ b/test-suite/bugkncst.v @@ -41,7 +41,7 @@ Fixpoint pocc_term (n:nat) (t:term): bool := | tApp fn args => pocc_term n fn || fold_left orb (map (pocc_term n) args) false | tConst nm _ => if eqb str nm then true else false | tCase _ ty mch brs => - existsb (pocc_term n) (pparams ty) || pocc_term n (preturn ty) || + existsb (pocc_term n) (pparams ty) || pocc_term n (preturn ty) || pocc_term n mch || fold_left orb (map (fun x => pocc_term n (bbody x)) brs) false | tFix ds _ => diff --git a/test-suite/erasure_live_test.v b/test-suite/erasure_live_test.v index 288e2fae0..e188f8a4c 100644 --- a/test-suite/erasure_live_test.v +++ b/test-suite/erasure_live_test.v @@ -19,7 +19,7 @@ Definition test (p : Ast.Env.program) : string := Definition test_fast (p : Ast.Env.program) : string := erase_fast_and_print_template_program p. - + MetaCoq Quote Recursively Definition zero := 0. Definition zerocst := Eval lazy in test zero. @@ -42,12 +42,12 @@ Definition singlelim := ((fun (X : Set) (x : X) (e : x = x) => end)). Definition erase {A} (a : A) : TemplateMonad unit := - aq <- tmQuoteRec a ;; + aq <- tmQuoteRec a ;; s <- tmEval lazy (erase_and_print_template_program aq) ;; tmMsg s. Definition erase_fast {A} (a : A) : TemplateMonad unit := - aq <- tmQuoteRec a ;; + aq <- tmQuoteRec a ;; s <- tmEval lazy (erase_fast_and_print_template_program aq) ;; tmMsg s. @@ -224,7 +224,7 @@ Time Definition ans_fib9 := (* [program] of the program *) MetaCoq Quote Recursively Definition p_fib9 := fib9. Definition P_fib9 := Eval lazy in (test p_fib9). -(* +(* Goal let env := (env P_fib9) in let main := (main P_fib9) in @@ -362,23 +362,23 @@ Definition fold_matchdecl {A B} (e : EnvCheck A) (b : A -> B) (c : PCUICAst.glob Ltac fold_matchdecls' := repeat match goal with - |- context C [?x] => - match x with + |- context C [?x] => + match x with | match ?l with CorrectDecl a => @?b a | EnvError g a' => @?c g a' end => change x with (fold_matchdecl l b c) end end. - + Set Printing Depth 20. - + Ltac eval_first := match goal with |- context C [fold_matchdecl ?l ?p ?g] => match l with (* | fold_matchdecl _ _ _ => fail 1 - *)| _ => + *)| _ => idtac "evaluating" l; let l' := eval lazy in l in let C' := context C [ fold_matchdecl l' p g] in @@ -388,7 +388,7 @@ end. Ltac show_match := match goal with - |- context [match ?x with _ => _ end] => + |- context [match ?x with _ => _ end] => match x with | match _ with _ => _ end => fail 1 | fold_matchdecl _ _ _ => fail 1 diff --git a/test-suite/evars.v b/test-suite/evars.v index 7ac22f79f..313c0b104 100644 --- a/test-suite/evars.v +++ b/test-suite/evars.v @@ -25,7 +25,7 @@ Local Open Scope string_scope. Goal list nat. (* Back and forth *) - let x := open_constr:(nil) in quote_term x (fun qt => + let x := open_constr:(nil) in quote_term x (fun qt => ltac:(denote_term qt (fun unqt => set (e := eq_refl : unqt = x :> list bool)))). (* Creation of evars by denotation of 'hole' *) let x := eval cbv in (tApp lnil [hole]) in diff --git a/test-suite/inferind.v b/test-suite/inferind.v index 35fdec1cc..db164e740 100644 --- a/test-suite/inferind.v +++ b/test-suite/inferind.v @@ -4,7 +4,7 @@ From MetaCoq.Template Require Import All. Import ListNotations. Import MCMonadNotation. Open Scope bs_scope. -Definition qlist := Eval compute in match <% list %> with +Definition qlist := Eval compute in match <% list %> with | tInd ind _ => ind.(inductive_mind) | _ => (MPfile nil, ""%bs) end. @@ -12,7 +12,7 @@ Definition qlist := Eval compute in match <% list %> with Definition refresh_sort t := match t with - | tSort s => + | tSort s => match s with | Universe.lProp => tSort Universe.lProp | Universe.lSProp => tSort Universe.lSProp @@ -21,7 +21,7 @@ Definition refresh_sort t := | _ => t end. -Definition refresh_arity s := +Definition refresh_arity s := let (ctx, concl) := decompose_prod_assum [] s in it_mkProd_or_LetIn ctx (refresh_sort concl). @@ -75,12 +75,12 @@ Definition refresh_arity s := mind_entry_variance := option_map (map Some) (ind_variance decl); mind_entry_private := None |}. - - + + Unset MetaCoq Strict Unquote Universe Mode. MetaCoq Run (tmQuoteInductive qlist >>= fun mib => - let entry := mind_body_to_entry mib in + let entry := mind_body_to_entry mib in entry <- tmEval all entry;; tmPrint entry ;; tmMkInductive true entry). diff --git a/test-suite/inferindunivs.v b/test-suite/inferindunivs.v index 2b816977f..b39f59fd3 100644 --- a/test-suite/inferindunivs.v +++ b/test-suite/inferindunivs.v @@ -28,27 +28,27 @@ Definition update_mutual_inductive_entry_inds (mie : mutual_inductive_entry) ind mind_entry_variance := mie.(mind_entry_variance); mind_entry_private := mie.(mind_entry_private) |}. -Definition add_cstr_univs (mie : mutual_inductive_entry) := +Definition add_cstr_univs (mie : mutual_inductive_entry) := let inds := mie.(mind_entry_inds) in let add_cstr oie := let cstrs := oie.(mind_entry_lc) in - let cstr' := + let cstr' := it_mkProd_or_LetIn mie.(mind_entry_params) (tProd (bnamed "newty"%bs) qv (tProd (bnamed "new") (mkApps rid [qu; tRel 0]) (mkApps (tRel (2 + List.length (mie.(mind_entry_params)))) (to_extended_list mie.(mind_entry_params))))) - in + in let prime_cstrs := List.map (fun s => s ++ "'") oie.(mind_entry_consnames) in {| mind_entry_typename := (oie.(mind_entry_typename) ++ "'"); - mind_entry_arity := (*oie.(mind_entry_arity)*) qw; + mind_entry_arity := (*oie.(mind_entry_arity)*) qw; mind_entry_lc := cstr' :: cstrs; mind_entry_consnames := "newcons" :: prime_cstrs |} in let inds' := List.map add_cstr inds in update_mutual_inductive_entry_inds mie inds'. -Inductive foo : Set := +Inductive foo : Set := | bar : foo. Definition fooref := (MPfile ["inferindunivs"; "TestSuite"; "MetaCoq"], "foo"). diff --git a/test-suite/issue28.v b/test-suite/issue28.v index efa3baea4..84e7b90c3 100644 --- a/test-suite/issue28.v +++ b/test-suite/issue28.v @@ -25,13 +25,13 @@ tFix [mkdef term (nNamed "f") (tProd (nNamed "x") (tApp (tInd (mkInd q_test 0) []) [tInd (mkInd q_unit 0) []]) (tInd (mkInd q_unit 0) [])) (tLambda (nNamed "x") (tApp (tInd (mkInd q_test 0) []) [tRel 0]) (tCase {|ci_ind := mkInd q_test 0; ci_npar := 1; ci_relevance := Relevant |} - {| pparams := [tInd (mkInd q_unit 0) []]; puinst := []; + {| pparams := [tInd (mkInd q_unit 0) []]; puinst := []; pcontext := [nNamed "X"]; preturn := (tInd (mkInd q_unit 0) []) |} (tRel 0) [{| bcontext := [nNamed "x0"]; bbody := (tApp (tRel 2) [tRel 0]) |}])) 0] 0. - + (* MetaCoq Run (tmEval cbv (print_term (empty_ext []) [] true T) >>= tmPrint). *) Fail MetaCoq Run (tmUnquote T >>= tmPrint). diff --git a/test-suite/modules_sections.v b/test-suite/modules_sections.v index 31320976e..9300bec4f 100644 --- a/test-suite/modules_sections.v +++ b/test-suite/modules_sections.v @@ -39,13 +39,13 @@ Section S. tmMkDefinition "bb" bc ;; tmPrint "lol"). Check bb. - + Variable x : nat. MetaCoq Run (bc <- tmQuote x ;; tmPrint bc ;; tmMkDefinition "bx" bc ;; tmPrint "lol"). - + Check bx. End S. diff --git a/test-suite/primitive.v b/test-suite/primitive.v index 0bf9b668e..e42461733 100644 --- a/test-suite/primitive.v +++ b/test-suite/primitive.v @@ -11,28 +11,28 @@ Definition bigint : PrimInt63.int := 542985047%int63. Notation eval_hnf := (tmEval hnf). Notation eval := (tmEval all). -MetaCoq Run (eval_hnf bigint >>= - (fun x => tmQuote (x + 1)%int63) >>= +MetaCoq Run (eval_hnf bigint >>= + (fun x => tmQuote (x + 1)%int63) >>= tmMkDefinition "foo"). Print foo. -MetaCoq Run (eval_hnf bigint >>= +MetaCoq Run (eval_hnf bigint >>= (fun x => tmQuote (x + 1)%int63 >>= fun q => tmUnquoteTyped int q >>= fun unq => tmPrint unq >>= fun _ => - tmLemma "foo'" (bigint + 1 = unq)%int63 >>= + tmLemma "foo'" (bigint + 1 = unq)%int63 >>= fun x => tmPrint x)). From Coq Require Import PrimFloat. Definition f := (- (of_uint63 bigint / 3))%float. Eval lazy in f. -MetaCoq Run (tmEval lazy f >>= - (fun x => tmQuote (x + 1)%float) >>= +MetaCoq Run (tmEval lazy f >>= + (fun x => tmQuote (x + 1)%float) >>= tmMkDefinition "fplus1"). -MetaCoq Run (tmUnquoteTyped float (tFloat f) >>= - (fun x : float => tmPrint x >>= +MetaCoq Run (tmUnquoteTyped float (tFloat f) >>= + (fun x : float => tmPrint x >>= fun _ => tmQuote x >>= tmMkDefinition "somefloat")). Print somefloat. diff --git a/test-suite/proj.v b/test-suite/proj.v index 7c013954a..cab6ec885 100644 --- a/test-suite/proj.v +++ b/test-suite/proj.v @@ -4,7 +4,7 @@ Set Primitive Projections. Record Eq (A : Type) := { eq : A -> A -> bool; eq_proof : forall x y, eq x y = true <-> x = y }. -Record Sigma (A : Type) (B : A -> Type) : Type := +Record Sigma (A : Type) (B : A -> Type) : Type := { fst : A ; snd : B fst }. Arguments fst {A B}. Arguments snd {A B}. diff --git a/test-suite/reduction_test.v b/test-suite/reduction_test.v index 3d78dbabf..cc835baa9 100644 --- a/test-suite/reduction_test.v +++ b/test-suite/reduction_test.v @@ -15,9 +15,9 @@ From MetaCoq.TestSuite Require hott_example. (* MetaCoq Quote Recursively Definition qequiv_adjointify := @isequiv_adjointify. *) -From MetaCoq.SafeChecker Require Import PCUICEqualityDec PCUICWfReduction PCUICErrors PCUICSafeReduce PCUICTypeChecker PCUICSafeChecker PCUICWfEnv PCUICWfEnvImpl SafeTemplateChecker PCUICSafeConversion. +From MetaCoq.SafeChecker Require Import PCUICEqualityDec PCUICWfReduction PCUICErrors PCUICSafeReduce PCUICTypeChecker PCUICSafeChecker PCUICWfEnv PCUICWfEnvImpl SafeTemplateChecker PCUICSafeConversion. -#[local,program] Instance fake_abstract_guard_impl : PCUICWfEnvImpl.abstract_guard_impl := +#[local,program] Instance fake_abstract_guard_impl : PCUICWfEnvImpl.abstract_guard_impl := { guard_impl := PCUICWfEnvImpl.fake_guard_impl }. @@ -25,11 +25,11 @@ Next Obligation. todo "this axiom is inconsitent, onlu used to make infer comput Definition typecheck_template (cf := default_checker_flags) {nor : normalizing_flags} (p : Ast.Env.program) - := - let p' := trans_program p in - match + := + let p' := trans_program p in + match infer_template_program (cf:=cf) p Monomorphic_ctx - with CorrectDecl X => + with CorrectDecl X => X.π1 (* PCUICPretty.print_env true 10 X.π2.π1.(wf_env_ext_referenced).(referenced_impl_env_ext) *) | _ => todo "should not happen" @@ -41,9 +41,9 @@ Inductive Empty (A:Set) : Set := . Definition dummy (n : nat) : nat := match n with 0 => 1 | S n => n end. -Set Primitive Projections. +Set Primitive Projections. -MetaCoq Quote Recursively Definition foo := +MetaCoq Quote Recursively Definition foo := @hott_example.isequiv_adjointify. (* plus. *) (* (fun n m => n + m). *) @@ -58,23 +58,23 @@ MetaCoq Quote Recursively Definition foo := Definition default_normal : @normalizing_flags default_checker_flags. now econstructor. -Defined. +Defined. Time Definition bar := Eval lazy in @typecheck_template default_normal foo. Unset MetaCoq Strict Unquote Universe Mode. MetaCoq Unquote Definition unbar := (PCUICToTemplate.trans bar). -Program Definition eval_compute (cf := default_checker_flags) +Program Definition eval_compute (cf := default_checker_flags) (nor : normalizing_flags) -(p : Ast.Env.program) φ : Ast.term + string +(p : Ast.Env.program) φ : Ast.term + string := match infer_template_program (cf:=cf) p φ return Ast.term + string with | CorrectDecl A => - let p' := trans_program p in + let p' := trans_program p in let Σ' := TemplateToPCUIC.trans_global_env p.1 in - let redtm := reduce_term RedFlags.default + let redtm := reduce_term RedFlags.default optimized_abstract_env_impl (proj1_sig A.π2) - [] p'.2 _ in + [] p'.2 _ in inl (PCUICToTemplate.trans redtm) | EnvError Σ (AlreadyDeclared id) => inr ("Already declared: " ^ id) @@ -84,14 +84,14 @@ end. Next Obligation. sq. destruct H0 as [? [? H0]]. pose (typing_wf_local H0). econstructor. rewrite <- e. eauto. -Qed. +Qed. -Program Definition eval_compute_cheat (cf := default_checker_flags) +Program Definition eval_compute_cheat (cf := default_checker_flags) (nor : normalizing_flags) (p : Ast.Env.program) φ : Ast.term -:= let p' := trans_program p in - let tm := reduce_term RedFlags.default - canonical_abstract_env_impl +:= let p' := trans_program p in + let tm := reduce_term RedFlags.default + canonical_abstract_env_impl {| referenced_impl_env_ext := (p'.1 , φ); referenced_impl_ext_wf := (todo "wf") |} [] p'.2 (todo "welltyped") in diff --git a/test-suite/univ.v b/test-suite/univ.v index b59e4f8a5..991a80ef3 100644 --- a/test-suite/univ.v +++ b/test-suite/univ.v @@ -70,7 +70,7 @@ Polymorphic Cumulative Record packType := {pk : Type}. MetaCoq Run (α <- tmQuoteInductive (cp "test") ;; tmPrint α). MetaCoq Run (tmQuoteInductive (cp "packType") >>= tmEval all >>= tmPrint). - + Polymorphic Cumulative Record Category@{i j} := { Obj : Type@{i}; Hom : Obj -> Obj -> Type@{j} }. Polymorphic Record Functor@{i j} (C D : Category@{i j}):= @@ -185,7 +185,7 @@ Definition test2 := (fun (T : Type@{i}) (T2 : Type@{j}) => T -> T2). Set Printing Universes. Print test. -Unset Printing Universes. +Unset Printing Universes. MetaCoq Quote Definition qtest := Eval compute in (fun (T : Type@{i}) (T2 : Type@{j}) => T -> T2). Print qtest. @@ -213,7 +213,7 @@ Section test. Set Printing Universes. Print t. - + End test. Compute t. diff --git a/translations/param_binary.v b/translations/param_binary.v index fd384daff..617bc8a7e 100644 --- a/translations/param_binary.v +++ b/translations/param_binary.v @@ -35,10 +35,10 @@ Definition suffix0 (n : name) s : name := Definition nAnon := {| binder_name := BasicAst.nAnon; binder_relevance := Relevant |}. Definition nNamed n := {| binder_name := BasicAst.nNamed n; binder_relevance := Relevant |}. - + Definition suffix na n := map_binder_annot (fun na => suffix0 na n) na. - + Fixpoint apply (app : list term) (t : term) := match app with | t' :: app => apply app (mkApp t (t' {3 := tRel 1} {2 := tRel 0})) @@ -75,7 +75,7 @@ Fixpoint tsl_rec1_app (app : list term) (E : tsl_table) (t : term) : term := let A1 := tsl_rec1 E A in let B1 := tsl_rec1 E B in let ΠAB0 := tProd na A0 B0 in - + tLambda (nNamed "f₁") ΠAB0 (tLambda (nNamed "f₂") ΠAB0 (tProd (suffix na "₁") (lift0 2 A0) @@ -192,11 +192,11 @@ Definition tsl_mind_body (E : tsl_table) (mp : modpath) (kn : kername) refine (subst_app _ [tConstruct (mkInd kn i) k []; tConstruct (mkInd kn i) k []]). refine (fold_left_i (fun t0 i u => t0 {S i := u} {S i := u}) _ (tsl_rec1 E type)). (* [I_0; ... I_(n-1)] *) - + refine (rev (mapi (fun i _ => tInd (mkInd kn i) []) mind.(ind_bodies))). refine (3 * arity)%nat. - + Defined. #[global] @@ -247,7 +247,7 @@ Module FreeTheorems. (* taken from coq-community/paramcoq *) Definition graph {A B} (f : A -> B) := fun x y => f x = y. Definition map_rel {A B} (f : A -> B) := listᵗ A B (graph f). - + Definition map_rel_map A B (f : A -> B) : forall (l : list A), map_rel f l (map f l). induction l; constructor; compute; auto. @@ -256,7 +256,7 @@ Module FreeTheorems. Lemma rel_map_map A B (f : A -> B) : forall (l : list A) fl, map_rel f l fl -> fl = map f l. intros l fl H. induction H; unfold graph in *; subst; auto. - Defined. + Defined. Definition FREE_THEOREM (F : MAP) := forall A B (f : A -> B) l, diff --git a/translations/param_cheap_packed.v b/translations/param_cheap_packed.v index 6b3ed7e58..e8038af7c 100644 --- a/translations/param_cheap_packed.v +++ b/translations/param_cheap_packed.v @@ -35,7 +35,7 @@ Fixpoint tsl_rec1 (n : nat) (t : term) {struct t} : term := (* | tCoFix : mfixpoint term -> nat -> term *) | _ => t end. - + Fixpoint tsl_rec2 (fuel : nat) (Σ : global_env) (G : universes_graph) (E : tsl_table) (Γ : context) (t : term) {struct fuel} : tsl_result term := @@ -146,7 +146,7 @@ Definition tsl_mind_body (ΣE : tsl_context) (mp : modpath) let Σ := fst (fst ΣE) in match gc_of_uctx (global_ext_uctx (fst ΣE)) with | None => raise (TypingError (UnsatisfiableConstraints (snd (global_ext_uctx (fst ΣE))))) - | Some ctrs => + | Some ctrs => let G := make_graph ctrs in let E := snd ΣE in let tsl_ty' := tsl_ty_param fuel Σ G E [] in @@ -157,7 +157,7 @@ Definition tsl_mind_body (ΣE : tsl_context) (mp : modpath) bodies <- _ ;; ret (_, [{| ind_npars := mind.(ind_npars); ind_bodies := bodies ; - ind_universes := match mind.(ind_universes) with + ind_universes := match mind.(ind_universes) with | Monomorphic_ctx => Monomorphic_ctx | Polymorphic_ctx ctx => Polymorphic_ctx ctx end; @@ -193,7 +193,7 @@ Definition tsl_mind_body (ΣE : tsl_context) (mp : modpath) let c1 := tsl_rec1 0 (tConstruct (mkInd kn i) k []) in match reduce_opt RedFlags.default (fst (fst ΣE)) [] (* for debugging but we could use try_reduce *) fuel (mkApp t2 c1) with - | Some t' => ret + | Some t' => ret {| cstr_name := tsl_ident c.(cstr_name); cstr_type := t'; cstr_args := c.(cstr_args); (* Not used by denotation yet *) @@ -208,7 +208,7 @@ Definition tsl_mind_body (ΣE : tsl_context) (mp : modpath) refine (IndRef (mkInd kn i), pair ind.(ind_type) a2 (tInd (mkInd kn i) []) (tInd (mkInd kn' i) [])). + (* ctors *) refine (fold_left_i (fun E k _ => _ :: E) ind.(ind_ctors) []). - exact (ConstructRef (mkInd kn i) k, tConstruct (mkInd kn' i) k []). + exact (ConstructRef (mkInd kn i) k, tConstruct (mkInd kn' i) k []). - exact mind.(ind_finite). - (* FIXME don't know what to do *) refine (mind.(ind_params)). Defined. @@ -497,7 +497,7 @@ Check (consᵗ : forall (A : TYPE) (x : El A) (lH : ∃ l, listᵗ A l), (* (* evenᵗ (S N.1; Sᵗ N) (even_S N.1 P.1). *) *) - + (* (* Class TranslationInductive := *) *) (* (* { tsl_ind : mutual_inductive_entry -> global_context * tsl_table }. *) *) diff --git a/translations/param_generous_unpacked.v b/translations/param_generous_unpacked.v index de3d2207e..616655691 100644 --- a/translations/param_generous_unpacked.v +++ b/translations/param_generous_unpacked.v @@ -20,7 +20,7 @@ Definition tsl_name n := Definition mkApps t us := tApp t us. (* meanwhile *) Definition mkApp t u := mkApps t [u]. -Definition default_term := tRel 0. +Definition default_term := tRel 0. Definition up := lift 1 0. @@ -272,7 +272,7 @@ Definition map_context_decl (f : term -> term) (decl : context_decl): context_de Notation " Γ ,, d " := (d :: Γ) (at level 20, d at next level, only parsing). - + Fixpoint tsl_ctx (E : tsl_table) (Γ : context) : context := match Γ with | [] => [] @@ -281,7 +281,7 @@ Fixpoint tsl_ctx (E : tsl_table) (Γ : context) : context := | Γ ,, decl => let n := decl.(decl_name) in let x := decl.(decl_body) in let A := decl.(decl_type) in - tsl_ctx E Γ ,, Build_context_decl n (omap (tsl_rec0 0) x) (tsl_rec0 0 A) + tsl_ctx E Γ ,, Build_context_decl n (omap (tsl_rec0 0) x) (tsl_rec0 0 A) ,, Build_context_decl (tsl_name n) (omap (lift 1 0 \o tsl_rec1 E 0) x) (mkApps (lift0 1 (tsl_rec1 E 0 A)) [tRel 0]) end. @@ -289,7 +289,7 @@ Delimit Scope term_scope with term. Notation "#| Γ |" := (List.length Γ) (at level 0, Γ at level 99, format "#| Γ |") : term_scope. - + Lemma tsl_ctx_length E (Γ : context) : #|tsl_ctx E Γ| = 2 * #|Γ|%term. Proof. induction Γ. @@ -339,7 +339,7 @@ Notation "( x ; y )" := (exist _ x y). (* set (Typing.safe_nth_obligation_2 context_decl (A :: Γ) (S n; p) A Γ eq_refl n eq_refl). *) (* specialize (IHn Γ c0 Heqt0 l). *) (* destruct IHn. *) - + (* unshelve econstructor. *) (* cbn. rewrite <- (tsl_ctx_length fuel Σ E Γ _ Heqt0). exact p. *) (* etransitivity. exact π2. cbn. *) @@ -454,7 +454,7 @@ elim/term_forall_list_ind : t n => //; rewrite ?plusE. (* - admit. *) Admitted. - + @@ -483,9 +483,9 @@ Proof. by []. Qed. (* From mathcomp Require Import ssrnat. *) Arguments safe_nth : simpl nomatch. - + Lemma eq_safe_nth T (l : list T) n n' p p' : n = n' -> - safe_nth l (n; p) = safe_nth l (n'; p') :> T. + safe_nth l (n; p) = safe_nth l (n'; p') :> T. Proof. move=> eq_n; case: _ / eq_n in p p' *. elim: l => [|x l IHl] in n p p' *. @@ -513,7 +513,7 @@ Qed. Lemma tsl_rec1_decl_type (Γ : context) (n : nat) (E : tsl_table) p p' (Γ' := tsl_ctx E Γ) : - mkApps (lift0 1 (decl_type (safe_nth Γ' ((2 * n); p)))) [tRel 0] = + mkApps (lift0 1 (decl_type (safe_nth Γ' ((2 * n); p)))) [tRel 0] = decl_type (safe_nth Γ' (2 * n; p')). Proof. subst Γ'; elim: Γ => [|a Γ IHΓ] in n p p' *. @@ -537,7 +537,7 @@ Admitted. (* Lemma tsl_rec1_decl_type (Γ : context) (n : nat) (isdecl : (n < #|Γ|%term)%coq_nat) (E : tsl_table) (isdecl' : (2 * n + 1 < #|tsl_ctx E Γ|%term)%coq_nat) *) (* : tsl_rec1 E (decl_type (safe_nth Γ (n; isdecl))) = *) (* decl_type (safe_nth (tsl_ctx E Γ) (2 * n + 1; isdecl')). *) - + Lemma tsl_correct Σ Γ t T (H : Σ ;;; Γ |-- t : T) : forall E, tsl_table_correct Σ E -> let Γ' := tsl_ctx E Γ in @@ -565,7 +565,7 @@ elim/typing_ind: H => {Γ t T} Γ. (* by rewrite plusE addn0 addn1. *) - + - admit. - admit. @@ -581,17 +581,17 @@ elim/typing_ind: H => {Γ t T} Γ. have [] := IHt' _ ΣE_correct. by move=> ? t1_ty; exact: t1_ty. admit. - - - + + + rewrite /Γ' => isdecl'; clear. case: Γ isdecl isdecl'. - - - + + + Require Import Vector. diff --git a/translations/param_original.v b/translations/param_original.v index 63a1c8e03..263b1ac5f 100644 --- a/translations/param_original.v +++ b/translations/param_original.v @@ -170,7 +170,7 @@ MetaCoq Run (typ <- tmQuote (forall A, A -> A) ;; tsl_tm := fun ΣE t => ret (tsl_rec1 (snd ΣE) t) ; (* Implement and Implement Existing cannot be used with this translation *) tsl_ty := None ; - tsl_ind := fun ΣE mp kn mind => + tsl_ind := fun ΣE mp kn mind => ret (tsl_mind_body (snd ΣE) mp kn mind) |}. diff --git a/translations/times_bool_fun.v b/translations/times_bool_fun.v index 3f8164067..ee6b1d59a 100644 --- a/translations/times_bool_fun.v +++ b/translations/times_bool_fun.v @@ -158,7 +158,7 @@ Definition tsl_mind_body (ΣE : tsl_context) (mp : modpath) (kn : kername) [{| ind_npars := mind.(ind_npars); ind_params := _; ind_bodies := snd LI; - ind_universes := mind.(ind_universes); + ind_universes := mind.(ind_universes); ind_variance := mind.(ind_variance)|}])). (* FIXME always ok? *) intros i ind. simple refine (let ind_type' := _ in @@ -241,22 +241,22 @@ Unset Universe Checking. MetaCoq Run (TC <- TranslateRec emptyTC NotFunext ;; tmDefinition "TC" TC ;; Implement TC "notFunext" NotFunext). -Next Obligation. +Next Obligation. unfold NotFunextᵗ; cbn in *. - tIntro H. - tSpecialize H unit. tSpecialize H unit. - tSpecialize H (fun x => x; true). tSpecialize H (fun x => x; false). + tIntro H. + tSpecialize H unit. tSpecialize H unit. + tSpecialize H (fun x => x; true). tSpecialize H (fun x => x; false). tSpecialize H (fun x => eq_reflᵗ _ _; true). - inversion H. + inversion H. Defined. MetaCoq Run (Implement TC "notη" ((forall (A B : Set) (f : A -> B), f = fun x => f x) -> False)). Next Obligation. - tIntro H. - tSpecialize H unit. tSpecialize H unit. + tIntro H. + tSpecialize H unit. tSpecialize H unit. tSpecialize H (fun x => x; false). cbn in H. - inversion H. + inversion H. Defined. (* Require Import Vector Even. *) diff --git a/translations/times_bool_fun2.v b/translations/times_bool_fun2.v index 71678ef4b..1a1b3641e 100644 --- a/translations/times_bool_fun2.v +++ b/translations/times_bool_fun2.v @@ -154,7 +154,7 @@ Definition contr_retract_α : contr_retractα. - intros [g p] x. refine (_ # (g x).2). exact (ap10 p x). - intro f; lazy. exact 1. (* uses eta! *) -Defined. +Defined. (* MetaCoq Run (TC <- TranslateRec eqTC3 contr_retractα ;; *) (* TC <- ImplementExisting TC "contr_retract_α" ;; *) diff --git a/translations/translation_utils.v b/translations/translation_utils.v index 4dd1b21f2..bac74b33f 100644 --- a/translations/translation_utils.v +++ b/translations/translation_utils.v @@ -88,7 +88,7 @@ Definition tsl_name0 tsl_ident n := Definition nAnon := {| binder_name := nAnon; binder_relevance := Relevant |}. Definition nNamed n := {| binder_name := nNamed n; binder_relevance := Relevant |}. - + Definition tsl_name f := map_binder_annot (tsl_name0 f). @@ -142,7 +142,7 @@ Definition Translate {tsl : Translation} (ΣE : tsl_context) (id : ident) tmMsg (string_of_kername kn ^ " has been translated.") ;; ret (Σ', E') end - + | ConstRef kn => e <- tmQuoteConstant kn true ;; match e.(cst_body) with @@ -186,7 +186,7 @@ Definition Implement {tsl : Translation} (ΣE : tsl_context) tA <- tmQuote A ;; match tsl_ty with | None => tmFail "No implementation of tsl_ty provided for this translation." - | Some tsl_ty => + | Some tsl_ty => tA' <- tmEval lazy (tsl_ty ΣE tA) ;; tmDebug tA' ;; match tA' with @@ -218,7 +218,7 @@ Definition ImplementExisting {tsl : Translation} (ΣE : tsl_context) (id : ident mp <- tmCurrentModPath tt ;; match tsl_ty with | None => tmFail "No implementation of tsl_ty provided for this translation." - | Some tsl_ty => + | Some tsl_ty => match gr with | VarRef _ => tmFail "Section variable not supported for the moment" | ConstRef kn => @@ -252,7 +252,7 @@ Definition ImplementExisting {tsl : Translation} (ΣE : tsl_context) (id : ident match List.nth_error (ind_bodies d) n with | None => fail_nf ("The declaration of " ^ id ^ " has not enough bodies. This is a bug.") - | Some {| ind_type := A |} => + | Some {| ind_type := A |} => tA' <- tmEval lazy (tsl_ty ΣE A) ;; match tA' with | Error e => @@ -276,7 +276,7 @@ Definition ImplementExisting {tsl : Translation} (ΣE : tsl_context) (id : ident match List.nth_error (ind_bodies d) n with | None => fail_nf ("The declaration of " ^ id ^ " has not enough bodies. This is a bug.") - | Some {| ind_ctors := ctors |} => + | Some {| ind_ctors := ctors |} => tmDebug "plop2" ;; match List.nth_error ctors k with | None => fail_nf ("The body of " @@ -307,7 +307,7 @@ Definition ImplementExisting {tsl : Translation} (ΣE : tsl_context) (id : ident end end. -Definition TranslateRec {tsl : Translation} (ΣE : tsl_context) {A} (t : A) := +Definition TranslateRec {tsl : Translation} (ΣE : tsl_context) {A} (t : A) := p <- tmQuoteRec t ;; tmPrint "~~~~~~~~~~~~~~~~~~" ;; monad_fold_right (fun ΣE '(kn, decl) => @@ -316,11 +316,11 @@ Definition TranslateRec {tsl : Translation} (ΣE : tsl_context) {A} (t : A) := | ConstantDecl decl => match lookup_tsl_table (snd ΣE) (ConstRef kn) with | Some _ => print_nf (string_of_kername kn ^ " was already translated") ;; ret ΣE - | None => + | None => match decl with | {| cst_body := None |} => fail_nf (string_of_kername kn ^ " is an axiom. Use Implement Existing.") - + | {| cst_type := A; cst_body := Some t; cst_universes := univs |} => tmDebug "go";; t' <- tmEval lazy (tsl_tm ΣE t) ;; @@ -349,16 +349,16 @@ Definition TranslateRec {tsl : Translation} (ΣE : tsl_context) {A} (t : A) := end end - | InductiveDecl d => + | InductiveDecl d => match lookup_tsl_table (snd ΣE) (IndRef (mkInd kn 0)) with | Some _ => print_nf (string_of_kername kn ^ " was already translated") ;; ret ΣE - | None => + | None => tmDebug "go'";; mp <- tmCurrentModPath tt ;; d' <- tmEval lazy (tsl_ind ΣE mp kn d) ;; tmDebug "done'";; match d' with - | Error e => + | Error e => print_nf e ;; fail_nf ("Translation error during the translation of the inductive " ^ string_of_kername kn)